home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 24 / CU Amiga Magazine's Super CD-ROM 24 (1998)(EMAP Images)(GB)(Track 1 of 2)[!][issue 1998-07].iso / CUCD / Programming / SWI / source / src / pl-wam.c < prev    next >
Encoding:
C/C++ Source or Header  |  1998-02-18  |  104.4 KB  |  3,696 lines
  1. /*  $Id: pl-wam.c,v 1.74 1998/02/18 13:57:32 jan Exp $
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: Virtual machine instruction interpreter
  8. */
  9.  
  10. /*#define O_SECURE 1*/
  11. /*#define O_DEBUG 1*/
  12. #include "pl-incl.h"
  13.  
  14. #if sun
  15. #include <prof.h>            /* in-function profiling */
  16. #else
  17. #define MARK(label)
  18. #endif
  19.  
  20. forwards void        copyFrameArguments(LocalFrame, LocalFrame, int);
  21. forwards inline bool    callForeign(const Definition, LocalFrame);
  22. forwards void        leaveForeignFrame(LocalFrame);
  23.  
  24. #if COUNTING
  25.  
  26. forwards void    countHeader(void);
  27. forwards void    countArray(char *, int *);
  28. forwards void    countOne(char *, int);
  29.  
  30. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  31. The counting code has been added while investigating the  time  critical
  32. WAM  instructions.   I'm afraid it has not been updated correctly since.
  33. Please  check  the  various  counting  macros  and  their  usage  before
  34. including this code.
  35. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  36.  
  37. static
  38. struct
  39. { int i_nop;
  40.   int h_const_n[256];
  41.   int b_const_n[256];
  42.   int h_sint[256];
  43.   int b_sint[256];
  44.   int h_nil;
  45.   int h_var_n[256];
  46.   int b_var_n[256];
  47.   int b_argvar_n[256];
  48.   int h_firstvar_n[256];
  49.   int b_firstvar_n[256];
  50.   int b_argfirstvar_n[256];
  51.   int h_void;
  52.   int b_void;
  53.   int h_functor;
  54.   int h_list;
  55.   int b_functor;
  56.   int i_pop;
  57.   int i_pop_n[256];
  58.   int i_enter;
  59. #if O_BLOCK
  60.   int i_cut_block;
  61.   int b_exit;
  62. #endif
  63.   int i_cut;
  64.   int i_usercall0;
  65.   int i_usercalln[256];
  66.   int i_apply;
  67.   int i_depart;
  68.   int i_call;
  69.   int i_exit;
  70.   int i_exitfact;
  71.   int d_break;
  72. #if O_COMPILE_ARITH
  73.   int a_indirect;
  74.   int a_func0[256];
  75.   int a_func1[256];
  76.   int a_func2[256];
  77.   int a_func[256];
  78.   int a_lt;
  79.   int a_le;
  80.   int a_gt;
  81.   int a_ge;
  82.   int a_eq;
  83.   int a_ne;
  84.   int a_is;
  85. #endif /* O_COMPILE_ARITH */
  86. #if O_COMPILE_OR
  87.   int c_or[256];
  88.   int c_jmp[256];
  89.   int c_mark[256];
  90.   int c_cut[256];
  91.   int c_ifthenelse[512];
  92.   int c_fail;
  93.   int c_end;
  94. #endif /* O_COMPILE_OR */
  95.   int i_fail;
  96.   int i_true;
  97. } counting;
  98.  
  99. forwards void countHeader();
  100. forwards void countOne();
  101. forwards void countArray();
  102.  
  103. word
  104. pl_count()
  105. { countHeader();
  106.   countArray("H_CONST",     counting.h_const_n);  
  107.   countArray("B_CONST",     counting.b_const_n);  
  108.   countArray("B_INDIRECT",    counting.b_indirect_n);  
  109.   countOne(  "H_NIL",         counting.h_nil);
  110.   countArray("H_VAR",         counting.h_var_n);  
  111.   countArray("B_VAR",         counting.b_var_n);  
  112.   countArray("B_ARGVAR",     counting.b_argvar_n);  
  113.   countArray("H_FIRSTVAR",     counting.h_firstvar_n);  
  114.   countArray("B_FIRSTVAR",     counting.b_firstvar_n);  
  115.   countArray("B_ARGFIRSTVAR",     counting.b_argfirstvar_n);  
  116.   countOne(  "H_VOID",         counting.h_void);
  117.   countOne(  "B_VOID",         counting.b_void);
  118.   countOne(  "H_FUNCTOR",     counting.h_functor_n);  
  119.   countOne(  "H_LIST",         counting.h_list);  
  120.   countOne(  "B_FUNCTOR",     counting.b_functor_n);  
  121.   countOne(  "I_POPF",         counting.i_pop);
  122.   countOne(  "I_ENTER",     counting.i_enter);
  123. #if O_BLOCK
  124.   countOne(  "I_CUT_BLOCK",    counting.i_cut_block);
  125.   countOne(  "B_EXIT",        counting.b_exit);
  126. #endif
  127.   countOne(  "I_CUT",         counting.i_cut);
  128.   countOne(  "I_USERCALL0",     counting.i_usercall0);
  129.   countArray("I_USERCALLN",    counting.i_usercalln);
  130.   countOne(  "I_APPLY",     counting.i_apply);
  131.   countOne(  "I_DEPART",     counting.i_depart);
  132.   countOne(  "I_CALL",         counting.i_call);
  133.   countOne(  "I_EXIT",         counting.i_exit);
  134.   countOne(  "I_EXITFACT",    counting.i_exitfact);
  135.   countOne(  "D_BREAK",        countOne.d_break);
  136.   countOne(  "I_FAIL",        countOne.i_fail);
  137.   countOne(  "I_TRUE",        countOne.i_true);
  138.  
  139.   succeed;
  140. }
  141.  
  142. static void
  143. countHeader()
  144. { int m;
  145.  
  146.   Putf("%13s: ", "Instruction");
  147.   for(m=0; m < 20; m++)
  148.     Putf("%8d", m);
  149.   Putf("\n");
  150.   for(m=0; m<(15+20*8); m++)
  151.     Putf("=");
  152.   Putf("\n");
  153. }  
  154.  
  155. static void
  156. countArray(s, array)
  157. char *s;
  158. int *array;
  159. { int n, m;
  160.  
  161.   for(n=255; array[n] == 0; n--) ;
  162.   Putf("%13s: ", s);
  163.   for(m=0; m <= n; m++)
  164.     Putf("%8d", array[m]);
  165.   Putf("\n");
  166. }
  167.  
  168. static void
  169. countOne(s, i)
  170. char *s;
  171. int i;
  172. { Putf("%13s: %8d\n", s, i);
  173. }
  174.  
  175. #define COUNT_N(name)  { counting.name[*PC]++; }
  176. #define COUNT_2N(name) { counting.name[*PC]++; counting.name[PC[1]+256]++; }
  177. #define COUNT(name)    { counting.name++; }
  178. #else /* ~COUNTING */
  179. #define COUNT_N(name)
  180. #define COUNT_2N(name)
  181. #define COUNT(name)
  182. #endif /* COUNTING */
  183.  
  184.  
  185. #include "pl-index.c"
  186. #include "pl-alloc.c"
  187.  
  188.          /*******************************
  189.          *        ASYNC HOOKS        *
  190.          *******************************/
  191.  
  192. #if O_ASYNC_HOOK
  193.  
  194. static struct
  195. { PL_async_hook_t    hook;        /* the hook function */
  196.   unsigned int        mask;        /* the mask */
  197. } async;
  198.  
  199.  
  200. PL_async_hook_t
  201. PL_async_hook(unsigned int count, PL_async_hook_t hook)
  202. { PL_async_hook_t old = async.hook;
  203.  
  204.   async.hook = hook;
  205.   async.mask = 1;
  206.   while(async.mask < count)
  207.     async.mask <<= 1;
  208.   async.mask--;
  209.  
  210.   return old;
  211. }
  212.  
  213.  
  214. #endif /*O_ASYNC_HOOK*/
  215.  
  216.  
  217.          /*******************************
  218.          *       STACK-LAYOUT        *
  219.          *******************************/
  220.  
  221. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  222. Brief description of the local stack-layout.  This stack contains:
  223.  
  224.     * struct localFrame structures for the Prolog stackframes.
  225.     * argument vectors and local variables for Prolog goals.
  226.     * term-references for foreign code.  The layout:
  227.  
  228.  
  229.     lTop  -->| first free location |
  230.          -----------------------
  231.          | local variables     |
  232.          |        ...           |
  233.          | arguments for goal  |
  234.          | localFrame struct   |
  235.          | queryFrame struct   |
  236.          -----------------------
  237.          |        ...           |
  238.          | term-references     |
  239.          -----------------------
  240.     lBase -->| # fliFrame struct   |
  241.          -----------------------
  242.  
  243. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  244.  
  245.  
  246.          /*******************************
  247.          *        FOREIGN FRAME    *
  248.          *******************************/
  249.  
  250. void
  251. finish_foreign_frame()
  252. { if ( fli_context )
  253.   { FliFrame fr = fli_context;
  254.  
  255.     if ( (unsigned long)environment_frame < (unsigned long) fr )
  256.     { fr->size = (Word) lTop - (Word)addPointer(fr, sizeof(struct fliFrame));
  257.       DEBUG(9, Sdprintf("Pushed fli context with %d term-refs\n", fr->size));
  258.     }
  259.   }
  260. }
  261.  
  262.  
  263. fid_t
  264. PL_open_foreign_frame()
  265. { FliFrame fr = (FliFrame) lTop;
  266.  
  267.   finish_foreign_frame();
  268.   requireStack(local, sizeof(struct fliFrame));
  269.   lTop = addPointer(lTop, sizeof(struct fliFrame));
  270.   fr->size = 0;
  271.   Mark(fr->mark);
  272.   fr->parent = fli_context;
  273.   fli_context = fr;
  274.  
  275.   return consTermRef(fr);
  276. }
  277.  
  278.  
  279. void
  280. PL_close_foreign_frame(fid_t id)
  281. { FliFrame fr = (FliFrame) valTermRef(id);
  282.  
  283.   fli_context = fr->parent;
  284.   lTop = (LocalFrame) fr;
  285. }
  286.  
  287.  
  288. void
  289. PL_discard_foreign_frame(fid_t id)
  290. { FliFrame fr = (FliFrame) valTermRef(id);
  291.  
  292.   Undo(fr->mark);
  293.   fli_context = fr->parent;
  294.   lTop = (LocalFrame) fr;
  295. }
  296.  
  297.  
  298.         /********************************
  299.         *         FOREIGN CALLS         *
  300.         *********************************/
  301.  
  302. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  303. Calling foreign predicates.  We will have to  set  `lTop',  compose  the
  304. argument  vector  for  the  foreign  function,  call  it and analyse the
  305. result.  The arguments of the frame are derefenced  here  to  avoid  the
  306. need for explicit dereferencing in most foreign predicates themselves.
  307.  
  308. A foreign predicate can  return  either  the  constant  FALSE  to  start
  309. backtracking,  TRUE to indicate success without alternatives or anything
  310. else.  The return value is saved in the `clause' slot of the frame.   In
  311. this  case  the  interpreter  will  leave a backtrack point and call the
  312. foreign function again with  the  saved  value  as  `backtrack  control'
  313. argument  if  backtracking is needed.  This `backtrack control' argument
  314. is appended to the argument list normally given to the foreign function.
  315. This makes it possible for  foreign  functions  that  do  not  use  this
  316. mechanism  to  ignore it.  For the first call the constant FIRST_CALL is
  317. given as `backtrack control'.
  318. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  319.  
  320. #define MAX_FLI_ARGS 10            /* extend switches on change */
  321.  
  322. #define CALLDETFN(r, argc) \
  323.   { switch(argc) \
  324.     { case 0: \
  325.     r = F(); \
  326.         break; \
  327.       case 1: \
  328.     r = F(A(0)); \
  329.     break; \
  330.       case 2: \
  331.     r = F(A(0),A(1)); \
  332.         break; \
  333.       case 3: \
  334.     r = F(A(0),A(1),A(2)); \
  335.         break; \
  336.       case 4: \
  337.     r = F(A(0),A(1),A(2),A(3)); \
  338.         break; \
  339.       case 5: \
  340.     r = F(A(0),A(1),A(2),A(3),A(4)); \
  341.         break; \
  342.       case 6: \
  343.     r = F(A(0),A(1),A(2),A(3),A(4),A(5)); \
  344.         break; \
  345.       case 7: \
  346.     r = F(A(0),A(1),A(2),A(3),A(4),A(5),A(6)); \
  347.         break; \
  348.       case 8: \
  349.     r = F(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7)); \
  350.         break; \
  351.       case 9: \
  352.     r = F(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8)); \
  353.         break; \
  354.       case 10: \
  355.     r = F(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9)); \
  356.         break; \
  357.       default: \
  358.     r = sysError("Too many arguments to foreign function (>%d)", \
  359.              MAX_FLI_ARGS); \
  360.     } \
  361.   }
  362.  
  363. #define CALLNDETFN(r, argc, c) \
  364.   { switch(argc) \
  365.     { case 0: \
  366.     r = F(c); \
  367.         break; \
  368.       case 1: \
  369.     r = F(A(0),(c)); \
  370.     break; \
  371.       case 2: \
  372.     r = F(A(0),A(1),(c)); \
  373.         break; \
  374.       case 3: \
  375.     r = F(A(0),A(1),A(2),(c)); \
  376.         break; \
  377.       case 4: \
  378.     r = F(A(0),A(1),A(2),A(3),(c)); \
  379.         break; \
  380.       case 5: \
  381.     r = F(A(0),A(1),A(2),A(3),A(4),(c)); \
  382.         break; \
  383.       case 6: \
  384.     r = F(A(0),A(1),A(2),A(3),A(4),A(5),(c)); \
  385.         break; \
  386.       case 7: \
  387.     r = F(A(0),A(1),A(2),A(3),A(4),A(5),A(6),(c)); \
  388.         break; \
  389.       case 8: \
  390.     r = F(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),(c)); \
  391.         break; \
  392.       case 9: \
  393.     r = F(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),(c)); \
  394.         break; \
  395.       case 10: \
  396.     r = F(A(0),A(1),A(2),A(3),A(4),A(5),A(6),A(7),A(8),A(9),(c)); \
  397.         break; \
  398.       default: \
  399.     r = sysError("Too many arguments to foreign function (>%d)", \
  400.              MAX_FLI_ARGS); \
  401.     } \
  402.   }
  403.  
  404.  
  405.  
  406. static inline bool
  407. callForeign(const Definition def, LocalFrame frame)
  408. { Func function = def->definition.function;
  409.   int argc = def->functor->arity;
  410.   word result;
  411.   term_t h0 = argFrameP(frame, 0) - (Word)lBase;
  412.   fid_t cid;
  413.   SaveLocalPtr(s1, frame);
  414.   
  415. #define F (*function)    
  416.  
  417.   lTop = (LocalFrame) argFrameP(frame, argc);
  418.   cid  = PL_open_foreign_frame();
  419.   exception_term = 0;
  420.  
  421. #define A(n) (h0+n)
  422.   if ( false(def, NONDETERMINISTIC) )    /* deterministic */
  423.   { CALLDETFN(result, argc);
  424.   } else                /* non-deterministic */
  425.   { word context = (word) frame->clause;
  426.     CALLNDETFN(result, argc, context);
  427.   }
  428. #undef A
  429.  
  430.   PL_close_foreign_frame(cid);        /* invalidates exception_term! */
  431.   RestoreLocalPtr(s1, frame);
  432.  
  433.   if ( result <= 1 )            /* FALSE || TRUE */
  434.   { frame->clause = NULL;
  435.     if ( result == 1 )
  436.       exception_term = 0;
  437.     return (bool) result;
  438.   } else
  439.   { if ( true(def, NONDETERMINISTIC) )
  440.     { if ( !result & FRG_CONTROL_MASK )
  441.       { warning("Illegal return value from foreign predicate %s: 0x%x",
  442.         predicateName(def), result);
  443.     fail;
  444.       }
  445.       frame->clause = (ClauseRef) result;
  446.       succeed;
  447.     }
  448.     warning("Deterministic foreign predicate %s returns 0x%x",
  449.         predicateName(def), result);
  450.     fail;
  451.   }
  452. }
  453.  
  454.  
  455. static void
  456. leaveForeignFrame(LocalFrame fr)
  457. { Definition def = fr->predicate;
  458.   int argc       = def->functor->arity;
  459.   Func function  = def->definition.function;
  460.   word context   = ((word) fr->clause & ~FRG_CONTROL_MASK) | FRG_CUTTED;
  461.   int  result;
  462.  
  463. #define F    (*function)
  464. #define A(n)    ((Word)NULL)
  465.  
  466.   DEBUG(5, Sdprintf("Cut %s, context = 0x%lx\n",
  467.             predicateName(def), context));
  468.  
  469.   CALLNDETFN(result, argc, context);
  470. #undef A
  471. #undef F
  472. }
  473.  
  474. #if O_DEBUGGER
  475. static void
  476. frameFinished(LocalFrame fr)
  477. { fid_t cid = PL_open_foreign_frame();
  478.  
  479.   callEventHook(PLEV_FRAMEFINISHED, fr);
  480.  
  481.   PL_discard_foreign_frame(cid);
  482. }
  483. #endif
  484.  
  485.          /*******************************
  486.          *         TRAILING        *
  487.          *******************************/
  488.  
  489. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  490. Trail an assignment.  This function  is  now   local  to  this module to
  491. exploit inlining facilities provided  by   good  C-compilers.  Note that
  492. -when using dynamic stacks-, the  assignment   should  be  made *before*
  493. calling Trail()!
  494.  
  495. The first version of Trail() is used only  by the WAM interpreter and is
  496. so much simpler because it is *known* that   p is either on the local or
  497. global stack and fr is available.
  498. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  499.  
  500. static inline void            /* used by the WAM interpreter */
  501. TrailLG(Word p, LocalFrame fr)
  502. { if ( p >= (Word) lBase )        /* gBase < gTop < lBase  */
  503.   { requireStack(trail, sizeof(struct trail_entry));
  504.     (tTop++)->address = consPtr(p, TAG_TRAILADDR|STG_LOCAL);
  505.   } else if ( p <= valPtr2(fr->mark.globaltop, STG_GLOBAL) )
  506.   { requireStack(trail, sizeof(struct trail_entry));
  507.     (tTop++)->address = consPtr(p, TAG_TRAILADDR|STG_GLOBAL);
  508.   }
  509. }
  510.  
  511.  
  512. static inline void
  513. Trail(Word p, LocalFrame fr)
  514. { int st;
  515.  
  516.   if ( p >= (Word)lBase )
  517.   { st = TAG_TRAILADDR|STG_LOCAL;
  518.   } else
  519.   { if ( fr && p > valPtr2(fr->mark.globaltop, STG_GLOBAL) )
  520.       return;
  521.     st = TAG_TRAILADDR|STG_GLOBAL;
  522.   }
  523.  
  524.   requireStack(trail, sizeof(struct trail_entry));
  525.   (tTop++)->address = consPtr(p, st);
  526. }
  527.  
  528.  
  529. void
  530. DoTrail(Word p)
  531. { Trail(p, environment_frame);
  532. }
  533.  
  534.  
  535. #ifdef O_DESTRUCTIVE_ASSIGNMENT
  536.  
  537. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  538. Trailing of destructive assignments.  This feature is used by setarg/3.
  539.  
  540. Such an assignment is trailed by first  pushing the assigned address (as
  541. normal) and then pushing a marked pointer to  a cell on the global stack
  542. holding the old (overwritten) value.
  543.  
  544. Undo is slightly more complicated as it has to check for these special
  545. cells on the trailstack.
  546.  
  547. The garbage collector has to take care in  a number of places: it has to
  548. pass through the trail-stack, marking   the  global-stack references for
  549. assigned data and the sweep_trail() must be   careful about this type of
  550. marks.
  551.  
  552. Note this function doesn't call Trail() for   the address as it can only
  553. be called from setarg/3 and the argument  is thus always a term-argument
  554. on the global stack.
  555. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  556.  
  557. void
  558. TrailAssignment(Word p)
  559. { Word old = allocGlobal(1);
  560.  
  561.   *old = *p;                /* save the old value on the global */
  562.   requireStack(trail, 2*sizeof(struct trail_entry));
  563.   (tTop++)->address = consPtr(p,   TAG_TRAILADDR|STG_GLOBAL);
  564.   (tTop++)->address = consPtr(old, TAG_TRAILVAL|STG_GLOBAL);
  565. }
  566.  
  567. #define UNDO_FUNC(name) \
  568. name(mark *m) \
  569. { TrailEntry tt = tTop; \
  570.   TrailEntry mt = (TrailEntry)valPtr2(m->trailtop, STG_TRAIL); \
  571.  \
  572.   SECURE(assert(m->trailtop  != INVALID_TRAILTOP); \
  573.      assert(m->globaltop != INVALID_GLOBALTOP)); \
  574.  \
  575.   while(tt > mt) \
  576.   { Word p; \
  577.  \
  578.     tt--; \
  579.     p = valPtr(tt->address); \
  580.     if ( tag(tt->address) == TAG_TRAILADDR ) \
  581.     { setVar(*p); \
  582.     } else /* if ( tag(tt->address) == TAG_TRAILVAL ) */ \
  583.     { word val = *p; \
  584.  \
  585.       tt--; \
  586.       *valPtr(tt->address) = val; \
  587.     } \
  588.   } \
  589.   tTop = tt; \
  590.   gTop = valPtr2(m->globaltop, STG_GLOBAL); \
  591. /*assert(gTop <= gMax);*/ \
  592. }
  593.  
  594. void UNDO_FUNC(do_undo)
  595. #ifdef HAVE_INLINE
  596. static __inline void UNDO_FUNC(__pl_do_undo)
  597. #undef Undo
  598. #define Undo(m) __pl_do_undo(&m)
  599. #endif
  600.  
  601. #endif /*O_DESTRUCTIVE_ASSIGNMENT*/
  602.  
  603.         /********************************
  604.         *          UNIFICATION          *
  605.         *********************************/
  606.  
  607. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  608. Unify is the general unification procedure. This raw routine should only
  609. be called by interpret as it  does   not  undo  bindings made during the
  610. unification in case the unification fails. pl_unify() (implementing =/2)
  611. does undo bindings and should be used   by  foreign predicates. See also
  612. unify_ptrs().
  613.  
  614. Unification depends on the datatypes available in the system and will in
  615. general need updating if new types are added.  It should be  noted  that
  616. unify()  is  not  the only place were unification happens.  Other points
  617. are:
  618.  
  619.   - various of the virtual machine instructions
  620.   - various macros, for example APPENDLIST and CLOSELIST
  621.   - unifyAtomic(), unifyFunctor(): unification of atomic data.
  622.   - various builtin predicates. They should be flagged some way.
  623. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  624.  
  625. bool
  626. unify(Word t1, Word t2, LocalFrame fr)
  627. { word w1;
  628.   word w2;
  629.  
  630. right_recursion:
  631.   w1 = *t1;
  632.   w2 = *t2;
  633.  
  634.   while(isRef(w1))            /* this is deRef() */
  635.   { t1 = unRef(w1);
  636.     w1 = *t1;
  637.   }
  638.   while(isRef(w2))
  639.   { t2 = unRef(w2);
  640.     w2 = *t2;
  641.   }
  642.  
  643.   if ( isVar(w1) )
  644.   { if ( isVar(w2) )
  645.     { if ( t1 < t2 )            /* always point downwards */
  646.       { *t2 = makeRef(t1);
  647.     Trail(t2, fr);
  648.     succeed;
  649.       }
  650.       if ( t1 == t2 )
  651.     succeed;
  652.       *t1 = makeRef(t2);
  653.       Trail(t1, fr);
  654.       succeed;
  655.     }
  656.     *t1 = w2;
  657.     Trail(t1, fr);
  658.     succeed;
  659.   }
  660.   if ( isVar(w2) )
  661.   { *t2 = w1;
  662.     Trail(t2, fr);
  663.     succeed;
  664.   }
  665.  
  666.   if ( w1 == w2 )
  667.     succeed;
  668.   if ( tag(w1) != tag(w2) )
  669.     fail;
  670.  
  671.   switch(tag(w1))
  672.   { case TAG_ATOM:
  673.       fail;
  674.     case TAG_INTEGER:
  675.       if ( storage(w1) == STG_INLINE ||
  676.        storage(w2) == STG_INLINE )
  677.     fail;
  678.     case TAG_STRING:
  679.     case TAG_FLOAT:
  680.       return equalIndirect(w1, w2);
  681.     case TAG_COMPOUND:
  682.     { int arity;
  683.       Functor f1 = valueTerm(w1);
  684.       Functor f2 = valueTerm(w2);
  685.  
  686.       if ( f1->definition != f2->definition )
  687.     fail;
  688.  
  689.       arity = arityFunctor(f1->definition);
  690.       t1 = f1->arguments;
  691.       t2 = f2->arguments;
  692.  
  693.       for(; --arity > 0; t1++, t2++)
  694.       { if ( !unify(t1, t2, fr) )
  695.       fail;
  696.       }
  697.       goto right_recursion;
  698.     }
  699.   }
  700.  
  701.   succeed;
  702. }
  703.  
  704.  
  705. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  706. Public unification procedure for  `raw'  data.   See  also  unify()  and
  707. PL_unify().
  708. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  709.  
  710. bool
  711. unify_ptrs(Word t1, Word t2)
  712. { mark m;
  713.   bool rval;
  714.  
  715.   Mark(m);
  716.   if ( !(rval = unify(t1, t2, environment_frame)) )
  717.     Undo(m);
  718.  
  719.   return rval;  
  720. }
  721.  
  722.  
  723. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  724. can_unify(t1, t2) succeeds if  two  terms   *can*  be  unified,  without
  725. actually doing so. This  is  basically   a  stripped  version of unify()
  726. above. See this function for comments.
  727. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  728.  
  729. bool
  730. can_unify(register Word t1, register Word t2)
  731. { mark m;
  732.  
  733.   bool rval;
  734.  
  735.   Mark(m);
  736.   rval = unify(t1, t2, environment_frame);
  737.   Undo(m);
  738.  
  739.   return rval;  
  740. }
  741.  
  742.  
  743. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  744. unify_atomic(p, a) is normally called through unifyAtomic(). It  unifies
  745. a  term,  represented  by  a pointer to it, with an atomic value.  It is
  746. intended for foreign language functions.
  747. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  748.  
  749. bool
  750. unify_atomic(Word p, word a)
  751. { deRef(p);
  752.  
  753.   if ( *p == a )
  754.     succeed;
  755.  
  756.   if ( isVar(*p) )
  757.   { *p = a;
  758.     Trail(p, environment_frame);
  759.     succeed;
  760.   }
  761.  
  762.   if ( isIndirect(a) && isIndirect(*p) )
  763.     return equalIndirect(a, *p);
  764.  
  765.   fail;
  766. }
  767.  
  768. #if O_BLOCK
  769.         /********************************
  770.         *         BLOCK SUPPORT         *
  771.         *********************************/
  772.  
  773. static LocalFrame
  774. findBlock(LocalFrame fr, Word block)
  775. { for(; fr; fr = fr->parent)
  776.   { if ( fr->predicate == PROCEDURE_block3->definition &&
  777.      unify_ptrs(argFrameP(fr, 0), block) )
  778.       return fr;
  779.   }
  780.  
  781.   warning("Can't find block");
  782.  
  783.   return NULL;
  784. }
  785.  
  786. #endif /*O_BLOCK*/
  787.  
  788. #if O_CATCHTHROW
  789.         /********************************
  790.         *        EXCEPTION SUPPORT      *
  791.         *********************************/
  792.  
  793. static LocalFrame
  794. findCatcher(LocalFrame fr, Word catcher)
  795. { for(; fr; fr = fr->parent)
  796.   { if ( fr->predicate == PROCEDURE_catch3->definition &&
  797.      unify_ptrs(argFrameP(fr, 1), catcher) )
  798.       return fr;
  799.   }
  800.  
  801.   return NULL;
  802. }
  803.  
  804. #endif /*O_CATCHTHROW*/
  805.  
  806.          /*******************************
  807.          *      TAIL-RECURSION    *
  808.          *******************************/
  809.  
  810. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  811. Tail recursion copy of the arguments of the new frame back into the  old
  812. one.   This  should  be  optimised  by the compiler someday, but for the
  813. moment this will do.
  814.  
  815. The new arguments block can contain the following types:
  816.   - Instantiated data (atoms, ints, reals, strings, terms
  817.     These can just be copied.
  818.   - Plain variables
  819.     These can just be copied.
  820.   - References to frames older than the `to' frame
  821.     These can just be copied.
  822.   - 1-deep references into the `to' frame.
  823.     This is hard as there might be two of  them  pointing  to  the  same
  824.     location  in  the  `to' frame, indicating sharing variables.  In the
  825.     first pass we will fill the  variable  in  the  `to'  frame  with  a
  826.     reference  to the new variable.  If we get another reference to this
  827.     field we will copy the reference saved in the `to'  field.   Because
  828.     on  entry  references into this frame are always 1 deep we KNOW this
  829.     is a saved reference.  The critical program for this is:
  830.  
  831.     a :- b(X, X).
  832.     b(X, Y) :- X == Y.
  833.     b(X, Y) :- write(bug), nl.
  834.  
  835.                     This one costed me 1/10 bottle of
  836.                     brandy to Huub Knops, SWI
  837. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  838.  
  839. static void
  840. copyFrameArguments(LocalFrame from, LocalFrame to, int argc)
  841. { Word ARGD, ARGS;
  842.   int n;
  843.  
  844.   if ( argc == 0 )
  845.     return;
  846.  
  847.   ARGS = argFrameP(from, 0);
  848.   ARGD = argFrameP(to, 0);
  849.   for( n=argc; --n >= 0; ARGS++, ARGD++) /* dereference the block */
  850.   { word k = *ARGS;
  851.  
  852.     if ( isRef(k) )
  853.     { Word p = unRef(k);
  854.  
  855.       if ( p > (Word)to )
  856.       { if ( isVar(*p) )
  857.     { *p = makeRefLG(ARGD);
  858.       setVar(*ARGS);
  859.     } else
  860.       *ARGS = *p;
  861.       }
  862.     }
  863.   }    
  864.   ARGS = argFrameP(from, 0);
  865.   ARGD = argFrameP(to, 0);
  866.   while(--argc >= 0)            /* now copy them */
  867.     *ARGD++ = *ARGS++;  
  868. }
  869.  
  870.         /********************************
  871.         *          INTERPRETER          *
  872.         *********************************/
  873.  
  874. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  875.              MACHINE REGISTERS
  876.  
  877.   - DEF
  878.     Definition structure of current procedure.
  879.   - PC
  880.     Virtual machine `program counter': pointer to the next byte code  to
  881.     interpret.
  882.   - ARGP
  883.     Argument pointer.  Pointer to the next argument to be matched  (when
  884.     in the clause head) or next argument to be instantiated (when in the
  885.     clause  body).   Saved  and  restored  via  the  argument  stack for
  886.     functors.
  887.   - FR
  888.     Current environment frame
  889.   - BFR
  890.     Frame where execution should continue if  the  current  goal  fails.
  891.     Used by I_CALL and deviates to fill the backtrackFrame slot of a new
  892.     frame and set by various instructions.
  893.   - deterministic
  894.     Last clause has been found deterministically
  895. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  896.  
  897. #define FRAME_FAILED        goto frame_failed
  898. #define CLAUSE_FAILED        goto clause_failed
  899. #define BODY_FAILED        goto body_failed
  900.  
  901. #ifndef O_SECURE
  902. #define SetBfr(fr)        (BFR = (fr))
  903. #else
  904. #define SetBfr(fr) \
  905.     do { \
  906.          assert(!(fr) || (fr)->mark.trailtop != INVALID_TRAILTOP); \
  907.          BFR = (fr); \
  908.        } while(0)
  909. #endif
  910.  
  911. #ifndef ulong
  912. #define ulong unsigned long
  913. #endif
  914.  
  915. qid_t
  916. PL_open_query(Module ctx, int flags, Procedure proc, term_t args)
  917. { QueryFrame qf;
  918.   LocalFrame fr;
  919.   Definition def;
  920.   int arity;
  921.   Word ap;
  922.   ClauseRef clause;
  923.  
  924.   DEBUG(4, { extern int Output;        /* --atoenne-- */
  925.          FunctorDef f = proc->definition->functor;
  926.  
  927.          if ( Output )
  928.          { int n;
  929.  
  930.            Putf("PL_open_query: %s(", stringAtom(f->name));
  931.            for(n=0; n < f->arity; n++)
  932.            { if ( n > 0 )
  933.            Putf(", ");
  934.          pl_write(args+n);
  935.            }
  936.            Putf(")\n");
  937.          } else
  938.            Sdprintf("PL_open_query in unitialized environment.\n");
  939.        });
  940.  
  941.   qf    = (QueryFrame) lTop;
  942.   fr    = &qf->frame;
  943.   def   = proc->definition;
  944.   arity    = def->functor->arity;
  945.  
  946.   SECURE(checkStacks(environment_frame));
  947.   assert((ulong)fli_context > (ulong)environment_frame);
  948.   assert((ulong)lTop >= (ulong)(fli_context+1));
  949.  
  950.   finish_foreign_frame();        /* adjust the size of the context */
  951.  
  952.   if ( flags == TRUE )            /* compatibility */
  953.     flags = PL_Q_NORMAL;
  954.   else if ( flags == FALSE )
  955.     flags = PL_Q_NODEBUG;
  956.   flags &= 0x1f;            /* mask reserved flags */
  957.  
  958.   qf->magic        = QID_MAGIC;
  959.   qf->flags        = flags;
  960.   qf->saved_environment = environment_frame;
  961.   qf->aSave             = aTop;
  962.   qf->solutions         = 0;
  963.   qf->bfr        = fr;
  964.   qf->exception        = 0;
  965.  
  966.   lTop = (LocalFrame) argFrameP(fr, arity);
  967.   verifyStack(local);
  968.  
  969.   fr->parent = NULL;
  970.                     /* fill frame arguments */
  971.   ap = argFrameP(fr, 0);
  972.   { int n;
  973.     Word p = valTermRef(args);
  974.  
  975.     for( n = arity; n-- > 0; p++ )
  976.       *ap++ = isVar(*p) ? makeRefLG(p) : *p;
  977.   }
  978.  
  979.                     /* find definition and clause */
  980.   if ( !(clause = def->definition.clauses) && false(def, DYNAMIC) )
  981.   { def = trapUndefined(def);
  982.     clause = def->definition.clauses;
  983.   }
  984.   if ( true(def, FOREIGN) )
  985.   { fr->clause = FIRST_CALL;
  986.   } else
  987.   { fr->clause = clause;
  988.   }
  989.                     /* context module */
  990.   if ( true(def, METAPRED) )
  991.   { if ( ctx )
  992.       fr->context = ctx;
  993.     else if ( environment_frame )
  994.       fr->context = environment_frame->context;
  995.     else
  996.       fr->context = MODULE_user;
  997.   } else
  998.     fr->context = def->module;
  999.  
  1000.   clearFlags(fr);
  1001. { LocalFrame parent;
  1002.   long plevel;
  1003.  
  1004.   if ( (parent = parentFrame(fr)) )
  1005.     plevel = levelFrame(parent);
  1006.   else
  1007.     plevel = 0L;
  1008.  
  1009.   setLevelFrame(fr, plevel);
  1010. }
  1011.             
  1012.   DEBUG(3, Sdprintf("Level = %d\n", levelFrame(fr)));
  1013.   if ( true(qf, PL_Q_NODEBUG) )
  1014.   { set(fr, FR_NODEBUG);
  1015.     debugstatus.suspendTrace++;
  1016.     qf->debugSave = debugstatus.debugging;
  1017.     debugstatus.debugging = FALSE;
  1018. #ifdef O_LIMIT_DEPTH
  1019.     qf->saved_depth_limit   = depth_limit;
  1020.     qf->saved_depth_reached = depth_reached;
  1021.     depth_limit = (unsigned long)DEPTH_NO_LIMIT;
  1022. #endif
  1023.   }
  1024.   fr->backtrackFrame = (LocalFrame) NULL;
  1025.   fr->predicate = def;
  1026.   Mark(fr->mark);
  1027.   environment_frame = fr;
  1028.  
  1029.   DEBUG(2, Sdprintf("QID=%d\n", QidFromQuery(qf)));
  1030.  
  1031.   return QidFromQuery(qf);
  1032. }
  1033.  
  1034.  
  1035. static void
  1036. discard_query(QueryFrame qf)
  1037. { LocalFrame FR  = &qf->frame;
  1038.   LocalFrame BFR = qf->bfr;
  1039.   LocalFrame fr, fr2;
  1040.  
  1041.   set(FR, FR_CUT);            /* execute I_CUT */
  1042.   for(fr = BFR; fr > FR; fr = fr->backtrackFrame)
  1043.   { for(fr2 = fr; fr2->clause && fr2 > FR; fr2 = fr2->parent)
  1044.     { DEBUG(3, Sdprintf("discard %d\n", (Word)fr2 - (Word)lBase) );
  1045.       leaveFrame(fr2);
  1046.       fr2->clause = NULL;
  1047.     }
  1048.   }
  1049.   leaveFrame(FR);
  1050. }
  1051.  
  1052.  
  1053. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1054. Restore the environment.  If an exception was raised by the query, and no
  1055. new exception has been thrown, consider it handled.
  1056. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1057.  
  1058. static void
  1059. restore_after_query(QueryFrame qf)
  1060. { if ( qf->exception && !exception_term )
  1061.     *valTermRef(exception_printed) = 0;
  1062.  
  1063.   environment_frame = qf->saved_environment;
  1064.   aTop            = qf->aSave;
  1065.   lTop            = (LocalFrame)qf;
  1066.   if ( true(qf, PL_Q_NODEBUG) )
  1067.   { debugstatus.suspendTrace--;
  1068.     debugstatus.debugging = qf->debugSave;
  1069. #ifdef O_LIMIT_DEPTH
  1070.     depth_limit   = qf->saved_depth_limit;
  1071.     depth_reached = qf->saved_depth_reached;
  1072. #endif /*O_LIMIT_DEPTH*/
  1073.   }
  1074.   SECURE(checkStacks(environment_frame));
  1075. }
  1076.  
  1077.  
  1078. void
  1079. PL_cut_query(qid_t qid)
  1080. { QueryFrame qf = QueryFromQid(qid);
  1081.  
  1082.   SECURE(assert(qf->magic == QID_MAGIC));
  1083.   qf->magic = 0;            /* disqualify the frame */
  1084.  
  1085.   if ( false(qf, PL_Q_DETERMINISTIC) )
  1086.     discard_query(qf);
  1087.  
  1088.   restore_after_query(qf);
  1089. }
  1090.  
  1091.  
  1092. void
  1093. PL_close_query(qid_t qid)
  1094. { QueryFrame qf = QueryFromQid(qid);
  1095.   LocalFrame fr = &qf->frame;
  1096.  
  1097.   SECURE(assert(qf->magic == QID_MAGIC));
  1098.   qf->magic = 0;            /* disqualify the frame */
  1099.  
  1100.   if ( false(qf, PL_Q_DETERMINISTIC) )
  1101.     discard_query(qf);
  1102.  
  1103.   if ( !(qf->exception && true(qf, PL_Q_PASS_EXCEPTION)) )
  1104.     Undo(fr->mark);
  1105.  
  1106.   restore_after_query(qf);
  1107. }
  1108.  
  1109.  
  1110. term_t
  1111. PL_exception(qid_t qid)
  1112. { QueryFrame qf = QueryFromQid(qid);
  1113.  
  1114.   return qf->exception;
  1115. }
  1116.  
  1117.  
  1118. #if O_SHIFT_STACKS
  1119. #define SAVE_REGISTERS(qid) \
  1120.     { QueryFrame qf = QueryFromQid(qid); \
  1121.       qf->registers.fr  = FR; \
  1122.       qf->registers.bfr = BFR; \
  1123.     }
  1124. #define LOAD_REGISTERS(qid) \
  1125.     { QueryFrame qf = QueryFromQid(qid); \
  1126.       FR = qf->registers.fr; \
  1127.       BFR = qf->registers.bfr; \
  1128.     }
  1129. #else /*O_SHIFT_STACKS*/
  1130. #define SAVE_REGISTERS(qid)
  1131. #define LOAD_REGISTERS(qid)
  1132. #endif /*O_SHIFT_STACKS*/
  1133.  
  1134. int
  1135. PL_next_solution(qid_t qid)
  1136. { QueryFrame QF;            /* Query frame */
  1137.   LocalFrame FR;            /* current frame */
  1138.   Word         ARGP;            /* current argument pointer */
  1139.   Code         PC;            /* program counter */
  1140.   LocalFrame BFR;            /* last backtrack frame */
  1141.   Definition DEF;            /* definition of current procedure */
  1142.   bool         deterministic;        /* clause found deterministically */
  1143.   Word *     aFloor = aTop;        /* don't overwrite old arguments */
  1144. #define         CL (FR->clause)        /* clause of current frame */
  1145.  
  1146. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1147. Get the labels of the various  virtual-machine instructions in an array.
  1148. This is for exploiting GCC's `goto   var' language extension. This array
  1149. can only be allocated insite this   function. The initialisation process
  1150. calls PL_next_solution() with qid =  QID_EXPORT_WAM_TABLE. This function
  1151. will export jmp_table as the compiler  needs   to  know  this table. See
  1152. pl-comp.c
  1153. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1154.  
  1155. #if O_LABEL_ADDRESSES
  1156.   static void *jmp_table[] =
  1157.   { &&I_NOP_LBL,
  1158.     &&I_ENTER_LBL,
  1159.     &&I_CALL_LBL,
  1160.     &&I_DEPART_LBL,
  1161.     &&I_EXIT_LBL,
  1162.     &&B_FUNCTOR_LBL,
  1163.     &&B_RFUNCTOR_LBL,
  1164.     &&H_FUNCTOR_LBL,
  1165.     &&H_RFUNCTOR_LBL,
  1166.     &&I_POPF_LBL,
  1167.     &&B_VAR_LBL,
  1168.     &&H_VAR_LBL,
  1169.     &&B_CONST_LBL,
  1170.     &&H_CONST_LBL,
  1171.     &&H_INDIRECT_LBL,
  1172.     &&B_INTEGER_LBL,
  1173.     &&H_INTEGER_LBL,
  1174.     &&B_FLOAT_LBL,
  1175.     &&H_FLOAT_LBL,
  1176.  
  1177.     &&B_FIRSTVAR_LBL,
  1178.     &&H_FIRSTVAR_LBL,
  1179.     &&B_VOID_LBL,
  1180.     &&H_VOID_LBL,
  1181.     &&B_ARGFIRSTVAR_LBL,
  1182.     &&B_ARGVAR_LBL,
  1183.  
  1184.     &&H_NIL_LBL,
  1185.     &&B_NIL_LBL,
  1186.     &&H_LIST_LBL,
  1187.     &&H_RLIST_LBL,
  1188.     &&B_LIST_LBL,
  1189.     &&B_RLIST_LBL,
  1190.  
  1191.     &&B_VAR0_LBL,
  1192.     &&B_VAR1_LBL,
  1193.     &&B_VAR2_LBL,
  1194.  
  1195.     &&I_USERCALL0_LBL,
  1196.     &&I_USERCALLN_LBL,
  1197.     &&I_CUT_LBL,
  1198.     &&I_APPLY_LBL,
  1199.  
  1200. #if O_COMPILE_ARITH
  1201.     &&A_ENTER_LBL,
  1202.     &&A_INTEGER_LBL,
  1203.     &&A_DOUBLE_LBL,
  1204.     &&A_VAR0_LBL,
  1205.     &&A_VAR1_LBL,
  1206.     &&A_VAR2_LBL,
  1207.     &&A_VAR_LBL,
  1208.     &&A_FUNC0_LBL,
  1209.     &&A_FUNC1_LBL,
  1210.     &&A_FUNC2_LBL,
  1211.     &&A_FUNC_LBL,
  1212.     &&A_LT_LBL,
  1213.     &&A_GT_LBL,
  1214.     &&A_LE_LBL,
  1215.     &&A_GE_LBL,
  1216.     &&A_EQ_LBL,
  1217.     &&A_NE_LBL,
  1218.     &&A_IS_LBL,
  1219. #endif /* O_COMPILE_ARITH */
  1220.  
  1221. #if O_COMPILE_OR
  1222.     &&C_OR_LBL,
  1223.     &&C_JMP_LBL,
  1224.     &&C_MARK_LBL,
  1225.     &&C_CUT_LBL,
  1226.     &&C_IFTHENELSE_LBL,
  1227.     &&C_VAR_LBL,
  1228.     &&C_END_LBL,
  1229.     &&C_NOT_LBL,
  1230.     &&C_FAIL_LBL,
  1231. #endif /* O_COMPILE_OR */
  1232.  
  1233.     &&B_INDIRECT_LBL,
  1234. #if O_BLOCK
  1235.     &&I_CUT_BLOCK_LBL,
  1236.     &&B_EXIT_LBL,
  1237. #endif /*O_BLOCK*/
  1238. #if O_INLINE_FOREIGNS
  1239.     &&I_CALL_FV0_LBL,
  1240.     &&I_CALL_FV1_LBL,
  1241.     &&I_CALL_FV2_LBL,
  1242. #endif /*O_INLINE_FOREIGNS*/
  1243.     &&I_FAIL_LBL,
  1244.     &&I_TRUE_LBL,
  1245. #ifdef O_SOFTCUT
  1246.     &&C_SOFTIF_LBL,
  1247.     &&C_SOFTCUT_LBL,
  1248. #endif
  1249.     &&I_EXITFACT_LBL,
  1250.     &&D_BREAK_LBL,
  1251. #if O_CATCHTHROW
  1252.     &&B_THROW_LBL,
  1253. #endif
  1254.     NULL
  1255.   };
  1256.  
  1257. #define VMI(Name, Count, Msg)    Name ## _LBL: Count; DEBUG(8, Sdprintf Msg);
  1258. #if VMCODE_IS_ADDRESS
  1259. #define NEXT_INSTRUCTION    goto *(void *)((long)(*PC++))
  1260. #else
  1261. #define NEXT_INSTRUCTION    goto *jmp_table[*PC++]
  1262. #endif
  1263.  
  1264. #else /* O_LABEL_ADDRESSES */
  1265.  
  1266. code thiscode;
  1267.  
  1268. #define VMI(Name, Count, Msg)    case Name: Count; DEBUG(8, Sdprintf Msg);
  1269. #define NEXT_INSTRUCTION    goto next_instruction
  1270.  
  1271. #endif /* O_LABEL_ADDRESSES */
  1272.  
  1273. #if VMCODE_IS_ADDRESS
  1274.   if ( qid == QID_EXPORT_WAM_TABLE )
  1275.   { interpreter_jmp_table = jmp_table;    /* make it globally known */
  1276.     succeed;
  1277.   }
  1278. #endif /* VMCODE_IS_ADDRESS */
  1279.  
  1280. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1281. This is the real start point  of   this  function.  Simply loads the VMI
  1282. registers from the frame filled by   PL_open_query()  and either jump to
  1283. depart_continue() to do the normal thing or to the backtrack point.
  1284. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1285.  
  1286.   QF  = QueryFromQid(qid);
  1287.   SECURE(assert(QF->magic == QID_MAGIC));
  1288.   FR  = &QF->frame;
  1289.   if ( true(QF, PL_Q_DETERMINISTIC) )    /* last one succeeded */
  1290.   { Undo(FR->mark);            /* undo */
  1291.     fail;
  1292.   }
  1293.  
  1294.   BFR = QF->bfr;
  1295.   DEF = FR->predicate;
  1296.   if ( QF->solutions )
  1297.   { if ( true(DEF, FOREIGN) )
  1298.     { Undo(FR->mark);
  1299. #if O_DEBUGGER
  1300.       if ( debugstatus.debugging )
  1301.       { switch( tracePort(FR, BFR, REDO_PORT, NULL) )
  1302.     { case ACTION_FAIL:
  1303.         set(QF, PL_Q_DETERMINISTIC);
  1304.         fail;
  1305.       case ACTION_IGNORE:
  1306.         set(QF, PL_Q_DETERMINISTIC);
  1307.         succeed;
  1308.       case ACTION_RETRY:
  1309.         CL->clause = NULL;
  1310.     }
  1311.       }
  1312. #endif /*O_DEBUGGER*/
  1313. #ifdef O_PROFILE
  1314.       if ( LD->statistics.profiling )
  1315.     DEF->profile_redos++;
  1316. #endif /* O_PROFILE */
  1317.       goto call_builtin;
  1318.     } else
  1319.       goto body_failed;
  1320.   } else
  1321.     goto depart_continue;
  1322.  
  1323. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1324. Main entry of the virtual machine cycle.  A branch to `next instruction'
  1325. will  cause  the  next  instruction  to  be  interpreted.   All  machine
  1326. registers  should  hold  valid  data  and  the  machine stacks should be
  1327. initialised properly.
  1328. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1329.  
  1330. #if O_LABEL_ADDRESSES
  1331.   NEXT_INSTRUCTION;
  1332. #else
  1333. next_instruction:
  1334.   thiscode = *PC++;
  1335. #ifdef O_DEBUGGER
  1336. resumebreak:
  1337. #endif
  1338.   switch( thiscode )
  1339. #endif
  1340.   {
  1341.  
  1342. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1343. D_BREAK implements break-points in the  code.   A  break-point is set by
  1344. replacing  an  instruction  by  a   D_BREAK  instruction.  The  orininal
  1345. instruction is saved in a table. replacedBreak() fetches it.
  1346.  
  1347. We might be in a state where  we   are  writing  the arguments above the
  1348. current lTop, and therefore with higher this  with the maximum number of
  1349. arguments.
  1350. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1351.     VMI(D_BREAK, COUNT(d_break), ("d_break\n"))
  1352. #if O_DEBUGGER
  1353.     if ( debugstatus.debugging )
  1354.     { int action;
  1355.       LocalFrame lSave = lTop;
  1356.  
  1357.       lTop = (LocalFrame)argFrameP(lTop, MAXARITY);
  1358.       clearUninitialisedVarsFrame(FR, PC-1);
  1359.       action = tracePort(FR, BFR, BREAK_PORT, PC-1);
  1360.       lTop = lSave;
  1361.  
  1362.       switch(action)
  1363.       { case ACTION_RETRY:
  1364.       goto retry;
  1365.       }
  1366.     }
  1367. #ifdef O_LABEL_ADDRESSES
  1368.     { void *c = (void *)replacedBreak(PC-1);
  1369.       
  1370.       goto *c;
  1371.     }
  1372. #else
  1373.     thiscode = replacedBreak(PC-1);
  1374.     goto resumebreak;
  1375. #endif      
  1376. #endif /*O_DEBUGGER*/
  1377.  
  1378.     VMI(I_NOP, COUNT(i_nop), ("i_nop\n"))
  1379.     NEXT_INSTRUCTION;
  1380.  
  1381. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1382. An atomic constant in the head  of  the  clause.   ARGP  points  to  the
  1383. current  argument  to be matched.  ARGP is derefenced and unified with a
  1384. constant argument.
  1385. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1386.  
  1387.   { word c;
  1388.     register Word k;                    MARK(HCONST);
  1389.  
  1390.     VMI(H_CONST,    COUNT_N(h_const_n),    ("h_const %d\n", *PC))
  1391.     c = (word)*PC++;
  1392.     goto common_hconst;
  1393.     VMI(H_NIL,        COUNT(h_nil),        ("h_nil\n"))
  1394.         c = ATOM_nil;
  1395.  
  1396.   common_hconst:
  1397.         deRef2(ARGP++, k);
  1398.         if (isVar(*k))
  1399.     { *k = c;
  1400.       TrailLG(k, FR);
  1401.       NEXT_INSTRUCTION;
  1402.     }
  1403.         if (*k == c)
  1404.       NEXT_INSTRUCTION;
  1405.         CLAUSE_FAILED;
  1406.   }
  1407.  
  1408. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1409. 32-bit integer in the head. Copy to the  global stack if the argument is
  1410. variable, compare the numbers otherwise.
  1411. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1412.  
  1413.     VMI(H_INTEGER,    COUNT(h_integer), ("h_integer %s\n", *PC)) MARK(HINT)
  1414.       { register Word k;
  1415.  
  1416.     deRef2(ARGP++, k);
  1417.     if (isVar(*k))
  1418.     { Word p = allocGlobal(3);
  1419.  
  1420.       *k   = consPtr(p, TAG_INTEGER|STG_GLOBAL);
  1421.       TrailLG(k, FR);
  1422.       *p++ = mkIndHdr(1, TAG_INTEGER);
  1423.       *p++ = (long)*PC++;
  1424.       *p++ = mkIndHdr(1, TAG_INTEGER);
  1425.       NEXT_INSTRUCTION;
  1426.     } else if ( isBignum(*k) && valBignum(*k) == (long)*PC++ )
  1427.       NEXT_INSTRUCTION;
  1428.  
  1429.           CLAUSE_FAILED;
  1430.       }  
  1431.  
  1432.     VMI(H_FLOAT,    COUNT(h_float), ("h_float\n")) MARK(HFLOAT)
  1433.       { register Word k;
  1434.  
  1435.     deRef2(ARGP++, k);
  1436.     if (isVar(*k))
  1437.     { Word p = allocGlobal(4);
  1438.  
  1439.       *k   = consPtr(p, TAG_FLOAT|STG_GLOBAL);
  1440.       TrailLG(k, FR);
  1441.       *p++ = mkIndHdr(2, TAG_FLOAT);
  1442.       *p++ = (long)*PC++;
  1443.       *p++ = (long)*PC++;
  1444.       *p++ = mkIndHdr(2, TAG_FLOAT);
  1445.       NEXT_INSTRUCTION;
  1446.     } else if ( isReal(*k) )
  1447.     { Word p = valIndirectP(*k);
  1448.  
  1449.       if ( *p++ == *PC++ && *p == *PC++ ) 
  1450.         NEXT_INSTRUCTION;
  1451.     }
  1452.  
  1453.           CLAUSE_FAILED;
  1454.       }  
  1455.  
  1456. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1457. General indirect in the head.  Used for strings only at the moment.
  1458. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1459.  
  1460.     VMI(H_INDIRECT, COUNT(h_indirect), ("h_indirect %d\n", *PC)) MARK(HINDIR);
  1461.       { register Word k;
  1462.  
  1463.     deRef2(ARGP++, k);
  1464.     if (isVar(*k))
  1465.     { *k = globalIndirectFromCode(&PC);
  1466.       TrailLG(k, FR);
  1467.       NEXT_INSTRUCTION;
  1468.     }
  1469.     if ( isIndirect(*k) && equalIndirectFromCode(*k, &PC) )
  1470.       NEXT_INSTRUCTION;
  1471.     CLAUSE_FAILED;
  1472.       }
  1473.  
  1474. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1475. An atomic constant in the body of  a  clause.   We  know  that  ARGP  is
  1476. pointing  to  a  not  yet  instantiated  argument  of the next frame and
  1477. therefore can just fill the argument.  Trailing is not needed as this is
  1478. above the stack anyway.
  1479. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1480.     VMI(B_CONST, COUNT_N(b_const_n), ("b_const %d\n", *PC)) MARK(BCONST);
  1481.       { *ARGP++ = (word)*PC++;
  1482.     NEXT_INSTRUCTION;
  1483.       }
  1484.     VMI(B_NIL, COUNT(b_nil), ("b_nil\n")) MARK(BNIL);
  1485.       { *ARGP++ = ATOM_nil;
  1486.         NEXT_INSTRUCTION;
  1487.       }
  1488.  
  1489. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1490. 32-bit integer in write-mode (body).  Simply   create  the bignum on the
  1491. global stack and assign the pointer to *ARGP.
  1492. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1493.  
  1494.     VMI(B_INTEGER,    COUNT(b_integer), ("b_integer %s\n", *PC)) MARK(BINT)
  1495.       { Word p = allocGlobal(3);
  1496.  
  1497.     *ARGP++ = consPtr(p, TAG_INTEGER|STG_GLOBAL);
  1498.     *p++ = mkIndHdr(1, TAG_INTEGER);
  1499.     *p++ = (long)*PC++;
  1500.     *p++ = mkIndHdr(1, TAG_INTEGER);
  1501.     NEXT_INSTRUCTION;
  1502.       }  
  1503.  
  1504. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1505. Double  in  the  body.  Simply  copy  to  the  global  stack.  See  also
  1506. globalReal().
  1507. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1508.  
  1509.     VMI(B_FLOAT,    COUNT(b_float), ("b_float\n")) MARK(BINT)
  1510.       { Word p = allocGlobal(4);
  1511.  
  1512.     *ARGP++ = consPtr(p, TAG_FLOAT|STG_GLOBAL);
  1513.     *p++ = mkIndHdr(2, TAG_FLOAT);
  1514.     *p++ = (long)*PC++;
  1515.     *p++ = (long)*PC++;
  1516.     *p++ = mkIndHdr(2, TAG_FLOAT);
  1517.     NEXT_INSTRUCTION;
  1518.       }  
  1519.  
  1520.  
  1521. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1522. B_INDIRECT need to copy the  value  on   the  global  stack  because the
  1523. XR-table might be freed due to a retract.
  1524. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1525.     VMI(B_INDIRECT, COUNT_N(b_indirect), ("b_indirect %d\n", *PC)) MARK(BIDT);
  1526.       { *ARGP++ = globalIndirectFromCode(&PC);
  1527.     NEXT_INSTRUCTION;
  1528.       }
  1529.  
  1530. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1531. A variable in the head which is not an anonymous one and is not used for
  1532. the first time.  Invoke general unification between the argument pointer
  1533. and the variable, whose offset is given relative to  the  frame.   Note:
  1534. this once was done in place to avoid a function call.  It turns out that
  1535. using a function call is faster (at least on SUN_3).
  1536. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1537.     VMI(H_VAR, COUNT_N(h_var_n), ("h_var %d\n", *PC)) MARK(HVAR);
  1538.       { Word p1 = varFrameP(FR, *PC++);
  1539.     Word p2 = ARGP++;
  1540.  
  1541.     deRef(p2);
  1542.     deRef(p1);
  1543.  
  1544.     if ( *p1 == *p2 )
  1545.     { if ( isVar(*p1) )
  1546.       { if ( p1 < p2 )        /* always point downwards */
  1547.         { *p2 = makeRef(p1);
  1548.           TrailLG(p2, FR);
  1549.         }
  1550.         if ( p1 > p2 )
  1551.         { *p1 = makeRef(p2);
  1552.           TrailLG(p1, FR);
  1553.         }
  1554.       }
  1555.       NEXT_INSTRUCTION;
  1556.     }
  1557.  
  1558.     if ( isVar(*p1) )
  1559.     { *p1 = *p2;
  1560.       TrailLG(p1, FR);
  1561.       NEXT_INSTRUCTION;
  1562.     }
  1563.     if ( isVar(*p2) )
  1564.     { *p2 = *p1;
  1565.       TrailLG(p2, FR);
  1566.       NEXT_INSTRUCTION;
  1567.     }
  1568.  
  1569.     switch(tag(*p1))
  1570.     { case TAG_ATOM:
  1571.         CLAUSE_FAILED;
  1572.       case TAG_INTEGER:
  1573.         if ( storage(*p1) != STG_INLINE &&
  1574.          isBignum(*p2) &&
  1575.          valBignum(*p1) == valBignum(*p2) )
  1576.           NEXT_INSTRUCTION;
  1577.         CLAUSE_FAILED;
  1578.       case TAG_STRING:
  1579.         if ( isString(*p2) && equalIndirect(*p1, *p2) )
  1580.           NEXT_INSTRUCTION;
  1581.         CLAUSE_FAILED;
  1582.       case TAG_FLOAT:
  1583.         if ( isReal(*p2) )
  1584.         { p1 = valIndirectP(*p1);
  1585.           p2 = valIndirectP(*p2);
  1586.           if ( p1[0] == p2[0] && p1[1] == p2[1] )
  1587.         NEXT_INSTRUCTION;
  1588.         }
  1589.         CLAUSE_FAILED;
  1590.       default:
  1591.         if ( unify(p1, p2, FR) )
  1592.           NEXT_INSTRUCTION;
  1593.         CLAUSE_FAILED;
  1594.     }
  1595.       }
  1596.  
  1597. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1598. A variable in the body which is not an anonymous one, is  not  used  for
  1599. the  first  time  and is nested in a term (with B_FUNCTOR).  We now know
  1600. that *ARGP is a variable,  so  we  either  copy  the  value  or  make  a
  1601. reference.   The  difference between this one and B_VAR is the direction
  1602. of the reference link in case *k turns out to be variable.
  1603. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1604.     VMI(B_ARGVAR, COUNT_N(b_argvar_n), ("b_argvar %d\n", *PC)) MARK(BAVAR);
  1605.       { register Word k;
  1606.  
  1607.     deRef2(varFrameP(FR, *PC++), k);    
  1608.     if (isVar(*k))
  1609.     { if (ARGP < k)
  1610.       { setVar(*ARGP);
  1611.         *k = makeRefLG(ARGP++);
  1612.         TrailLG(k, FR);
  1613.         NEXT_INSTRUCTION;
  1614.       }
  1615.       *ARGP++ = makeRefLG(k);        /* both on global stack! */
  1616.       NEXT_INSTRUCTION;      
  1617.     }
  1618.     *ARGP++ = *k;
  1619.  
  1620.     NEXT_INSTRUCTION;
  1621.       }
  1622. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1623. A variable in the body which is not an anonymous one and is not used for
  1624. the first time.  We now know that *ARGP is a variable, so we either copy
  1625. the value or make a reference.  Trailing is not needed as we are writing
  1626. above the stack.
  1627. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1628.  
  1629. #define BODY_VAR(n)   { register Word k; \
  1630.             deRef2(varFrameP(FR, (n)), k); \
  1631.             *ARGP++ = (isVar(*k) ? makeRefLG(k) : *k); \
  1632.             NEXT_INSTRUCTION; \
  1633.               }
  1634.     VMI(B_VAR, COUNT_N(b_var_n), ("b_var %d\n", *PC)) MARK(BVARN);
  1635.       BODY_VAR(*PC++);
  1636.     VMI(B_VAR0, COUNT(b_var_n[9]), ("b_var 9\n")) MARK(BVAR0);
  1637.       BODY_VAR(ARGOFFSET / sizeof(word));
  1638.     VMI(B_VAR1, COUNT(b_var_n[10]), ("b_var 10\n")) MARK(BVAR1);
  1639.       BODY_VAR(1 + ARGOFFSET / sizeof(word));
  1640.     VMI(B_VAR2, COUNT(b_var_n[11]), ("b_var 11\n")) MARK(BVAR2);
  1641.       BODY_VAR(2 + ARGOFFSET / sizeof(word));
  1642.  
  1643. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1644. A variable in the head, which is not anonymous, but encountered for  the
  1645. first  time.  So we know that the variable is still a variable.  Copy or
  1646. make a reference.  Trailing is not needed as  we  are  writing  in  this
  1647. frame.
  1648. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1649.     VMI(H_FIRSTVAR, COUNT_N(h_firstvar_n), ("h_firstvar %d\n", *PC))
  1650.       MARK(HFVAR);
  1651.       { varFrame(FR, *PC++) = (isVar(*ARGP) ? makeRefLG(ARGP++)
  1652.                            : *ARGP++);
  1653.     NEXT_INSTRUCTION;
  1654.       }
  1655. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1656. A variable in the body nested in a term, encountered for the first time.
  1657. We now know both *ARGP and the variable are variables.  ARGP  points  to
  1658. the  argument  of  a  term  on  the  global stack.  The reference should
  1659. therefore go from k to ARGP.
  1660. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1661.     VMI(B_ARGFIRSTVAR, COUNT_N(b_argfirstvar_n), ("b_argfirstvar %d\n", *PC))
  1662.       MARK(BAFVAR);
  1663.       { setVar(*ARGP);
  1664.     varFrame(FR, *PC++) = makeRefLG(ARGP++);
  1665.     NEXT_INSTRUCTION;
  1666.       }
  1667. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1668. A variable in the body, encountered for the first  time.   We  now  know
  1669. both  *ARGP and the variable are variables.  We set the variable to be a
  1670. variable (it is uninitialised memory) and make a reference.  No trailing
  1671. needed as we are writing in this and the next frame.
  1672. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1673.     VMI(B_FIRSTVAR, COUNT_N(b_firstvar_n), ("b_firstvar %d\n", *PC))
  1674.       MARK(BFVAR);
  1675.       { register Word k = varFrameP(FR, *PC++);
  1676.  
  1677.     setVar(*k);
  1678.     *ARGP++ = makeRefLG(k);
  1679.     NEXT_INSTRUCTION;
  1680.       }
  1681. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1682. A singleton variable in the head.  Just increment the argument  pointer.
  1683. Also generated for non-singleton variables appearing on their own in the
  1684. head  and  encountered  for  the  first  time.   Note  that the compiler
  1685. suppresses H_VOID when there are no other instructions before I_ENTER or
  1686. I_EXIT.
  1687. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1688.     VMI(H_VOID, COUNT(h_void), ("h_void\n")) MARK(HVOID);
  1689.       { ARGP++;
  1690.     NEXT_INSTRUCTION;
  1691.       }
  1692. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1693. A singleton variable in the body. Ensure the argument is a variable.
  1694. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1695.     VMI(B_VOID, COUNT(b_void), ("b_void\n")) MARK(BVOID);
  1696.       { setVar(*ARGP++);
  1697.     NEXT_INSTRUCTION;
  1698.       }
  1699. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1700. A functor in the head.  If the current argument is a  variable  we  will
  1701. instantiate  it  with  a  new  term,  all  whose  arguments  are  set to
  1702. variables.  Otherwise we check the functor  definition.   In  both  case
  1703. ARGP  is  pushed  on the argument stack and set to point to the leftmost
  1704. argument of the  term.   Note  that  the  instantiation  is  trailed  as
  1705. dereferencing might have caused we are now pointing in a parent frame or
  1706. the global stack (should we check?  Saves trail! How often?).
  1707. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1708.  
  1709.     VMI(H_FUNCTOR, COUNT_N(h_functor_n), ("h_functor %d\n", *PC))
  1710.       MARK(HFUNC);
  1711.       { functor_t f;
  1712.  
  1713.     requireStack(argument, sizeof(Word));
  1714.     *aTop++ = ARGP + 1;
  1715.     VMI(H_RFUNCTOR, COUNT_N(h_rfunctor_n), ("h_rfunctor %d\n", *PC))
  1716.     f = (functor_t) *PC++;
  1717.         deRef(ARGP);
  1718.     if ( isVar(*ARGP) )
  1719.     { int arity = arityFunctor(f);
  1720.       Word ap;
  1721.  
  1722. #ifdef O_SHIFT_STACKS
  1723.       if ( gTop + 1 + arity > gMax )
  1724.         growStacks(FR, PC, FALSE, TRUE, FALSE);
  1725. #else
  1726.       requireStack(global, sizeof(word)*(1+arity));
  1727. #endif
  1728.  
  1729.       ap = gTop;
  1730.       *ARGP = consPtr(ap, TAG_COMPOUND|STG_GLOBAL);
  1731.       TrailLG(ARGP, FR);
  1732.       *ap++ = f;
  1733.       ARGP = ap;
  1734.       while(arity-- > 0)
  1735.       { setVar(*ap++);
  1736.       }
  1737.       gTop = ap;
  1738.       NEXT_INSTRUCTION;
  1739.     }
  1740.     if ( hasFunctor(*ARGP, f) )
  1741.     { ARGP = argTermP(*ARGP, 0);
  1742.       NEXT_INSTRUCTION;
  1743.     }
  1744.     CLAUSE_FAILED;        
  1745.  
  1746.     VMI(H_LIST, COUNT(h_list), ("h_list\n")) MARK(HLIST);
  1747.         requireStack(argument, sizeof(Word));
  1748.     *aTop++ = ARGP + 1;
  1749.     VMI(H_RLIST, COUNT(h_rlist), ("h_rlist\n")) MARK(HRLIST);
  1750.     deRef(ARGP);
  1751.     if ( isVar(*ARGP) )
  1752.     { 
  1753. #if O_SHIFT_STACKS
  1754.         if ( gTop + 3 > gMax )
  1755.         growStacks(FR, PC, FALSE, TRUE, FALSE);
  1756. #else
  1757.       requireStack(global, 3*sizeof(word));
  1758. #endif
  1759.       *ARGP = consPtr(gTop, TAG_COMPOUND|STG_GLOBAL);
  1760.       TrailLG(ARGP, FR);
  1761.       *gTop++ = FUNCTOR_dot2;
  1762.       ARGP = gTop;
  1763.       setVar(*gTop++);
  1764.       setVar(*gTop++);
  1765.       NEXT_INSTRUCTION;
  1766.     }
  1767.     if ( isList(*ARGP) )
  1768.     { ARGP = argTermP(*ARGP, 0);
  1769.       NEXT_INSTRUCTION;
  1770.     }
  1771.     CLAUSE_FAILED;
  1772.       }
  1773.  
  1774. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1775. A functor in the body.  As we don't expect ARGP to point to  initialised
  1776. memory  while  in  body  mode  we  just  allocate  the  term,  but don't
  1777. initialise the arguments to variables.  Allocation is done in  place  to
  1778. avoid a function call.
  1779. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1780.     VMI(B_FUNCTOR, COUNT(b_functor), ("b_functor %d\n", *PC)) MARK(BFUNC);
  1781.       { functor_t f;
  1782.     int arity;
  1783.  
  1784.     requireStack(argument, sizeof(Word));
  1785.     *aTop++ = ARGP+1;
  1786.     VMI(B_RFUNCTOR, COUNT(b_rfunctor), ("b_rfunctor %d\n", *PC)) MARK(BRFUNC);
  1787.     f = (functor_t) *PC++;
  1788.     arity = arityFunctor(f);
  1789.     requireStack(global, sizeof(word) * (1+arity));
  1790.     *ARGP = consPtr(gTop, TAG_COMPOUND|STG_GLOBAL);
  1791.     *gTop++ = f;
  1792.     ARGP = gTop;
  1793.     gTop += arity;
  1794.  
  1795.     NEXT_INSTRUCTION;
  1796.       }
  1797.  
  1798.     VMI(B_LIST, COUNT(b_list), ("b_list\n")) MARK(BLIST);
  1799.       { requireStack(argument, sizeof(Word));
  1800.     *aTop++ = ARGP+1;
  1801.     VMI(B_RLIST, COUNT(b_rlist), ("b_rlist %d\n", *PC)) MARK(BRLIST);
  1802.     requireStack(global, sizeof(word) * 3);
  1803.     *ARGP = consPtr(gTop, TAG_COMPOUND|STG_GLOBAL);
  1804.     *gTop++ = FUNCTOR_dot2;
  1805.     ARGP = gTop;
  1806.     gTop += 2;
  1807.  
  1808.     NEXT_INSTRUCTION;
  1809.       }
  1810.  
  1811. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1812. Pop the saved argument pointer (see H_FUNCTOR and B_FUNCTOR).
  1813. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1814.  
  1815.     VMI(I_POPF, COUNT(i_pop), ("pop\n")) MARK(POP);
  1816.       { ARGP = *--aTop;
  1817.     NEXT_INSTRUCTION;
  1818.       }
  1819.  
  1820. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1821. Enter the body of the clause.  This  instruction  is  left  out  if  the
  1822. clause  has no body.  The basic task of this instruction is to move ARGP
  1823. from the argument part of this frame into the argument part of the child
  1824. frame to be built.  `BFR' (the last frame with alternatives) is  set  to
  1825. this   frame   if   this   frame  has  alternatives,  otherwise  to  the
  1826. backtrackFrame of this frame.
  1827.  
  1828. If this frame has no alternatives it is possible to  put  the  backtrack
  1829. frame  immediately  on  the backtrack frame of this frame.  This however
  1830. makes debugging much more  difficult  as  the  system  will  do  a  deep
  1831. backtrack without showing the fail ports explicitely.
  1832. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1833.     VMI(I_ENTER, COUNT(i_enter), ("enter\n")) MARK(ENTER);
  1834.       { 
  1835. #if O_DEBUGGER
  1836.     if ( debugstatus.debugging )
  1837.     { clearUninitialisedVarsFrame(FR, PC);
  1838.       switch(tracePort(FR, BFR, UNIFY_PORT, PC))
  1839.       { case ACTION_RETRY:
  1840.           goto retry;
  1841.         case ACTION_FAIL:
  1842.           FRAME_FAILED;
  1843.       }
  1844.       if ( FR->mark.trailtop == INVALID_TRAILTOP )
  1845.       { SetBfr(FR->backtrackFrame);
  1846.       } else
  1847.       { SetBfr(FR);
  1848.       }
  1849.     } else
  1850. #endif /*O_DEBUGGER*/
  1851.     { if ( true(FR, FR_CUT) )
  1852.       { SetBfr(FR->backtrackFrame);
  1853.       } else
  1854.       { SetBfr(FR);
  1855.       }
  1856.     }
  1857.  
  1858.     ARGP = argFrameP(lTop, 0);
  1859.         NEXT_INSTRUCTION;
  1860.       }
  1861.  
  1862. #if O_CATCHTHROW
  1863. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1864. ISO-Compliant catch/3, throw/1  support  in   the  virtual  machine. See
  1865. boot/init.pl for the definion of these predicates.
  1866.  
  1867. The B_THROW code is the implementation for   throw/1.  The call walks up
  1868. the stack, looking for a frame running catch/3 on which it can unify the
  1869. exception code. It then cuts all  choicepoints created since throw/3. If
  1870. throw/3 is not found, it sets  the   query  exception  field and returns
  1871. failure. Otherwise, it will simulate an I_USERCALL0 instruction: it sets
  1872. the FR and lTop as it it  was   running  the  throw/3 predicate. Then it
  1873. pushes the recovery goal from throw/3 and jumps to I_USERCALL0.
  1874. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1875.     b_throw:
  1876.     VMI(B_THROW, COUNT(b_throw), ("b_throw")) MARK(B_THROW);
  1877.       { Word catcher;
  1878.     word except;
  1879.     LocalFrame catchfr, fr, fr2;
  1880.  
  1881.     if ( exception_term )        /* PL_throw() generated */
  1882.       catcher = valTermRef(exception_term);
  1883.     else                /* throw/1 generated */
  1884.       catcher = argFrameP(lTop, 0);
  1885.     deRef(catcher);
  1886.     except = *catcher;
  1887.         catchfr = findCatcher(FR, catcher);
  1888.  
  1889.     SECURE(checkData(catcher));    /* verify all data on stacks stack */
  1890.  
  1891. #if O_DEBUGGER
  1892.     if ( !catchfr &&
  1893.          hasFunctor(except, FUNCTOR_error2) &&
  1894.          *valTermRef(exception_printed) != except )
  1895.     { QF = QueryFromQid(qid);    /* reload for relocation */
  1896.  
  1897.       if ( false(QF, PL_Q_CATCH_EXCEPTION|PL_Q_PASS_EXCEPTION) ||
  1898.            trueFeature(DEBUG_ON_ERROR_FEATURE) )
  1899.       { fid_t fid = PL_open_foreign_frame();
  1900.         term_t t0 = PL_new_term_refs(2);
  1901.         
  1902.         PL_put_atom(t0+0, ATOM_error);
  1903.         *valTermRef(t0+1) = except;
  1904.         PL_call_predicate(NULL, FALSE, PROCEDURE_print_message2, t0);
  1905.         PL_close_foreign_frame(fid);
  1906.         *valTermRef(exception_printed) = except;
  1907.  
  1908.         pl_trace();
  1909.       }
  1910.     }
  1911. #endif /*O_DEBUGGER*/
  1912.  
  1913.     for( ; FR && FR > catchfr; FR = FR->parent )
  1914.     { /* Destroy older choicepoints */
  1915.       for(fr = BFR; fr && fr > FR; fr = fr->backtrackFrame)
  1916.       { for(fr2 = fr; fr2 && fr2->clause && fr2 > FR; fr2 = fr2->parent)
  1917.         { DEBUG(3, Sdprintf("discard %d\n", (Word)fr2 - (Word)lBase) );
  1918.           leaveFrame(fr2);
  1919.           fr2->clause = NULL;
  1920.         }
  1921.       }
  1922.       SetBfr(FR->mark.trailtop != INVALID_TRAILTOP ?
  1923.          FR : FR->backtrackFrame);
  1924.  
  1925. #if O_DEBUGGER
  1926.       if ( debugstatus.debugging )
  1927.       { switch(tracePort(FR, BFR, EXCEPTION_PORT, PC))
  1928.         { case ACTION_RETRY:
  1929.         *valTermRef(exception_printed) = 0;
  1930.         goto retry;
  1931.         }
  1932.       }
  1933. #endif
  1934.       leaveFrame(FR);
  1935.       FR->clause = NULL;
  1936.     }
  1937.  
  1938.     if ( catchfr )
  1939.     { code exit_instruction;
  1940.  
  1941.       assert(catchfr == FR);
  1942.       SetBfr(FR->mark.trailtop != INVALID_TRAILTOP ?
  1943.          FR : FR->backtrackFrame);
  1944.       environment_frame = FR;
  1945.       lTop = (LocalFrame) argFrameP(FR, 3); /* above the catch/3 */
  1946.       argFrame(lTop, 0) = argFrame(FR, 2);  /* copy recover goal */
  1947.       *valTermRef(exception_printed) = 0;   /* consider it handled */
  1948.       *valTermRef(exception_bin)     = 0;
  1949.  
  1950.       exit_instruction = encode(I_EXIT);    /* we must continue with */
  1951.       PC = &exit_instruction;        /* an I_EXIT. Use catch? */
  1952.  
  1953.       goto i_usercall0;
  1954.     } else
  1955.     { QF = QueryFromQid(qid);    /* may be shifted: recompute */
  1956.       set(QF, PL_Q_DETERMINISTIC);
  1957.       FR = environment_frame = &QF->frame;
  1958.       lTop = (LocalFrame) argFrameP(FR, 3); /* ??? */
  1959.                     /* needs a foreign frame? */
  1960.       QF->exception = PL_new_term_ref();
  1961.       *valTermRef(exception_printed) = 0;   /* consider it handled */
  1962.       *valTermRef(exception_bin)     = 0;
  1963.  
  1964.       *valTermRef(QF->exception) = except;
  1965.  
  1966.       fail;
  1967.     }
  1968.       }
  1969. #endif /*O_CATCHTHROW*/
  1970.  
  1971. #if O_BLOCK
  1972. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1973. exit(Block, RVal).  First does !(Block).
  1974. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1975.     VMI(B_EXIT, COUNT(b_exit), ("b_exit")) MARK(B_EXIT);
  1976.       { Word name, rval;
  1977.     LocalFrame blockfr, fr, fr2;
  1978.  
  1979.     name = argFrameP(lTop, 0); deRef(name);
  1980.     rval = argFrameP(lTop, 1); deRef(rval);
  1981.  
  1982.         if ( !(blockfr = findBlock(FR, name)) )
  1983.     { BODY_FAILED;
  1984.     }
  1985.     
  1986.     set(blockfr, FR_CUT);
  1987.     for(fr = BFR; fr > blockfr; fr = fr->backtrackFrame)
  1988.     { for(fr2 = fr; fr2->clause && fr2 > blockfr; fr2 = fr2->parent)
  1989.       { DEBUG(3, Sdprintf("discard %d\n", (Word)fr2 - (Word)lBase) );
  1990.         leaveFrame(fr2);
  1991.         fr2->clause = NULL;
  1992.       }
  1993.     }
  1994. #ifdef O_DEBUGGER
  1995.         if ( debugstatus.debugging )
  1996.     { SetBfr(blockfr->mark.trailtop != INVALID_TRAILTOP ?
  1997.          blockfr : blockfr->backtrackFrame);
  1998.     } else
  1999. #endif
  2000.     { SetBfr(blockfr->backtrackFrame);
  2001.     }
  2002.  
  2003.     for(fr = FR; fr > blockfr; fr = fr->parent)
  2004.     { set(fr, FR_CUT);
  2005.       fr->backtrackFrame = BFR;
  2006.     }
  2007.  
  2008.     DEBUG(3, Sdprintf("BFR = %d\n", (Word)BFR - (Word)lBase) );
  2009.  
  2010.     if ( unify(argFrameP(blockfr, 2), rval, environment_frame) ) /*???*/
  2011.     { for( ; FR > blockfr; FR = FR->parent )
  2012.       { leaveFrame(FR);
  2013.         FR->clause = NULL;
  2014.         if ( FR->parent == blockfr )
  2015.           PC = FR->programPointer;
  2016.       }
  2017.                     /* TBD: tracing? */
  2018.  
  2019.           environment_frame = FR;
  2020.       DEF = FR->predicate;
  2021.       lTop = (LocalFrame) argFrameP(FR, CL->clause->variables);
  2022.       ARGP = argFrameP(lTop, 0);
  2023.  
  2024.       NEXT_INSTRUCTION;
  2025.     } else
  2026.     { lTop = (LocalFrame) argFrameP(FR, CL->clause->variables);
  2027.       ARGP = argFrameP(lTop, 0);
  2028.  
  2029.       BODY_FAILED;
  2030.     }
  2031.       }
  2032.  
  2033. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2034. !(Block).  Cuts all alternatives created after entering the named block.
  2035. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2036.     VMI(I_CUT_BLOCK, COUNT(i_cut_block), ("i_cut_block\n")) MARK(CUT_BLOCK);
  2037.       { LocalFrame cutfr, fr, fr2;
  2038.     Word name;
  2039.  
  2040.     name = argFrameP(lTop, 0); deRef(name);
  2041.  
  2042.     if ( !(cutfr = findBlock(FR, name)) )
  2043.     { BODY_FAILED;
  2044.     }
  2045.     
  2046. #ifdef O_DEBUGGER
  2047.     if ( debugstatus.debugging )
  2048.     { SetBfr(cutfr->mark.trailtop != INVALID_TRAILTOP ?
  2049.          cutfr : cutfr->backtrackFrame);
  2050.     } else
  2051. #endif
  2052.     { SetBfr(cutfr->backtrackFrame);
  2053.     }
  2054.  
  2055.     for(fr = FR; fr > cutfr; fr = fr->parent)
  2056.     { set(fr, FR_CUT);
  2057.       fr->backtrackFrame = BFR;
  2058.     }
  2059.     set(cutfr, FR_CUT);
  2060.  
  2061.     for(fr = BFR; fr > cutfr; fr = fr->backtrackFrame)
  2062.     { for(fr2 = fr; fr2->clause && fr2 > cutfr; fr2 = fr2->parent)
  2063.       { if ( false(fr, FR_CUT) )
  2064.         { DEBUG(3, Sdprintf("discard [%ld] %s\n",
  2065.                 levelFrame(fr), predicateName(fr->predicate)));
  2066.           leaveFrame(fr2);
  2067.           fr2->clause = NULL;
  2068.         }
  2069.       }
  2070.     }
  2071.  
  2072.     DEBUG(3, Sdprintf("BFR = [%ld] %s\n",
  2073.               levelFrame(BFR),
  2074.               predicateName(BFR->predicate)));
  2075.  
  2076.     lTop = (LocalFrame) argFrameP(FR, CL->clause->variables);
  2077.     ARGP = argFrameP(lTop, 0);
  2078.  
  2079.     NEXT_INSTRUCTION;
  2080.       }
  2081. #endif /*O_BLOCK*/
  2082.  
  2083. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2084. !. Basic task is to mark the frame, telling it  is  cut  off,  restoring
  2085. `BFR'  to the backtrack frame of this frame (this, nor one of the childs
  2086. has alternatives left due to the cut).  `lTop'  is  set  to  point  just
  2087. above this frame, as all childs can be abbandoned now.
  2088.  
  2089. After the cut all child frames with alternatives and their parents  that
  2090. are childs of this frame become garbage.  The interpreter will visit all
  2091. these  frames  and  decrease the references of the clauses referenced by
  2092. the Prolog goals.
  2093.  
  2094. If the debugger is on we change the backtrack frame to this frame rather
  2095. than to the  backtrackframe  of  the  current  frame  to  avoid  a  long
  2096. backtrack that makes it difficult to understand the tracer's output.
  2097. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2098.     i_cut:            /* from I_USERCALL0 */
  2099.     VMI(I_CUT, COUNT(i_cut), ("cut frame %d\n", REL(FR))) MARK(CUT);
  2100.       { LocalFrame fr;
  2101.     register LocalFrame fr2;
  2102.  
  2103. #ifdef O_DEBUGGER
  2104.     if ( debugstatus.debugging )
  2105.     { switch(tracePort(FR, BFR, CUT_CALL_PORT, PC))
  2106.       { case ACTION_RETRY:
  2107.           goto retry;
  2108.         case ACTION_FAIL:
  2109.           FRAME_FAILED;
  2110.       }
  2111.     }
  2112. #endif
  2113.  
  2114.     set(FR, FR_CUT);
  2115.     for(fr = BFR; fr > FR; fr = fr->backtrackFrame)
  2116.     { for(fr2 = fr; fr2->clause && fr2 > FR; fr2 = fr2->parent)
  2117.       { DEBUG(3, Sdprintf("discard frame of %s\n",
  2118.                   predicateName(fr2->predicate)));
  2119.         leaveFrame(fr2);
  2120.         fr2->clause = NULL;
  2121.       }
  2122.     }
  2123. #ifdef O_DEBUGGER
  2124.         if ( debugstatus.debugging )
  2125.     { SetBfr(FR->mark.trailtop != INVALID_TRAILTOP ?
  2126.          FR : FR->backtrackFrame);
  2127.     } else
  2128. #endif
  2129.         { SetBfr(FR->backtrackFrame);
  2130.     }
  2131.  
  2132.     DEBUG(3, Sdprintf("BFR = %d\n", (Word)BFR - (Word)lBase) );
  2133.     lTop = (LocalFrame) argFrameP(FR, CL->clause->variables);
  2134.     ARGP = argFrameP(lTop, 0);
  2135.  
  2136. #ifdef O_DEBUGGER
  2137.     if ( debugstatus.debugging )
  2138.     { switch(tracePort(FR, BFR, CUT_EXIT_PORT, PC))
  2139.       { case ACTION_RETRY:
  2140.           goto retry;
  2141.         case ACTION_FAIL:
  2142.           FRAME_FAILED;
  2143.       }
  2144.     }
  2145. #endif
  2146.  
  2147.     NEXT_INSTRUCTION;
  2148.       }
  2149.  
  2150. #if O_COMPILE_OR
  2151. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2152. WAM support for ``A ; B'', ``A -> B'' and ``A -> B ; C'' constructs.  As
  2153. these functions introduce control within the WAM instructions  they  are
  2154. tagged `C_'.
  2155. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2156.  
  2157. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2158. C_JMP skips the amount stated in the pointed argument.   The  PC++
  2159. could be compiled out, but this is a bit more neath.
  2160. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2161.     VMI(C_JMP, COUNT_N(c_jmp), ("c_jmp %d\n", *PC)) MARK(C_JMP);
  2162.       { PC += *PC;
  2163.     PC++;
  2164.  
  2165.     NEXT_INSTRUCTION;
  2166.       }
  2167.  
  2168. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2169. C_MARK saves the value of BFR  (current   backtrack  frame) into a local
  2170. frame slot reserved by the compiler.  Note that the variable to hold the
  2171. local-frame pointer is  *not*  reserved   in  clause->variables,  so the
  2172. garbage collector won't see it.  With the introduction of stack-shifting
  2173. this slot has been made relative to lBase.
  2174. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2175.    VMI(C_MARK, COUNT_N(c_mark), ("c_mark %d\n", *PC)) MARK(C_MARK);
  2176.       { varFrame(FR, *PC++) = (word) BFR;
  2177.  
  2178.     NEXT_INSTRUCTION;
  2179.       }
  2180.  
  2181. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2182. C_VAR is generated by the compiler to ensure the  instantiation  pattern
  2183. of  the  variables  is  the  same after finishing both paths of the `or'
  2184. wired in the clause.  Its task is to make the n-th variable slot of  the
  2185. current frame to be a variable.
  2186. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2187.    VMI(C_VAR, COUNT_N(c_var), ("c_var %d\n", *PC)) MARK(C_VAR);
  2188.       { setVar(varFrame(FR, *PC++));
  2189.  
  2190.     NEXT_INSTRUCTION;
  2191.       }
  2192.  
  2193. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2194. C_CUT will  destroy  all  backtrack  points  created  after  the  C_MARK
  2195. instruction in this clause.  It assumes the value of BFR has been stored
  2196. in the nth-variable slot of the current local frame.
  2197.  
  2198. We can dereference all frames that are older that the old backtrackframe
  2199. and older than this frame.
  2200.  
  2201. All frames created since what becomes now the  backtrack  point  can  be
  2202. discarded.
  2203. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2204.     VMI(C_CUT, COUNT_N(c_cut), ("c_cut %d\n", *PC)) MARK(C_CUT);
  2205.       { LocalFrame obfr = (LocalFrame) varFrame(FR, *PC);
  2206.     LocalFrame cbfr = obfr;
  2207.     LocalFrame fr;
  2208.     register LocalFrame fr2;
  2209.  
  2210.     PC++;                /* cannot be in macro! */
  2211.     if ( cbfr < FR )
  2212.       cbfr = FR;
  2213.  
  2214.     for(fr = BFR; fr > cbfr; fr = fr->backtrackFrame)
  2215.     { for(fr2 = fr; fr2->clause && fr2 > cbfr; fr2 = fr2->parent)
  2216.       { DEBUG(3, Sdprintf("discard %d: ", (Word)fr2 - (Word)lBase) );
  2217.         /*DEBUG(3, writeFrameGoal(fr2, 2); pl_nl() );*/
  2218.         leaveFrame(fr2);
  2219.         fr2->clause = NULL;
  2220.       }
  2221.     }
  2222.  
  2223.     /*DEBUG(3, Putf("BFR at "); writeFrameGoal(BFR, 2); pl_nl() );*/
  2224.     { int nvar = (true(cbfr->predicate, FOREIGN)
  2225.                 ? cbfr->predicate->functor->arity
  2226.                 : cbfr->clause->clause->variables);
  2227.       lTop = (LocalFrame) argFrameP(cbfr, nvar);
  2228.       ARGP = argFrameP(lTop, 0);
  2229.     }
  2230.         SetBfr(obfr);
  2231.  
  2232.         NEXT_INSTRUCTION;
  2233.       }
  2234.  
  2235. #ifdef O_SOFTCUT
  2236. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2237. Handle the commit-to of A *-> B; C.  Simply mark the $alt/1 frame as cutted,
  2238. and control will not reach C again.
  2239. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2240.     VMI(C_SOFTCUT, COUNT_N(c_softcut), ("c_softcut %d\n", *PC)) MARK(CSOFTCUT);
  2241.       { LocalFrame altfr = (LocalFrame) varFrame(FR, *PC);
  2242.  
  2243.     assert(altfr->predicate == PROCEDURE_alt1->definition);
  2244.     PC++;
  2245.     set(altfr, FR_CUT);
  2246.     NEXT_INSTRUCTION;
  2247.       }
  2248. #endif
  2249.  
  2250. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2251. C_END is a dummy instruction to help the decompiler to find the end of A
  2252. ->  B.  (Note  that  a  :-  (b  ->  c),  d == a :- (b -> c, d) as far as
  2253. semantics.  They are different terms however.
  2254. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2255.    VMI(C_END, COUNT(c_end), ("c_end\n")) MARK(C_END);
  2256.       {    NEXT_INSTRUCTION;
  2257.       }
  2258.  
  2259. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2260. C_FAIL is equivalent to fail/0. Used to implement \+/1.
  2261. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2262.    VMI(C_FAIL, COUNT(c_fail), ("c_fail\n")) MARK(C_FAIL);
  2263.       {    BODY_FAILED;
  2264.       }
  2265. #endif /* O_COMPILE_OR */
  2266.  
  2267. #if O_COMPILE_ARITH
  2268. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2269. Arithmic is compiled using a  stack  machine.    ARGP  is  used as stack
  2270. pointer and the arithmic stack is allocated   on top of the local stack,
  2271. starting at the argument field of the next slot of the stack (where ARGP
  2272. points to when processing the body anyway).
  2273.  
  2274. Arguments to functions are pushed on the stack  starting  at  the  left,
  2275. thus `add1(X, Y) :- Y is X + 1' translates to:
  2276.  
  2277.     I_ENTER    % enter body
  2278.     B_VAR1    % push Y via ARGP
  2279.     A_ENTER    % align the stack to prepare for writing doubles
  2280.     A_VAR0    % evaluate X and push numeric result
  2281.     A_INTEGER 1    % Push 1 as numeric value
  2282.     A_FUNC2 0    % Add top-two of the stack and push result
  2283.     A_IS     % unify Y with numeric result
  2284.     I_EXIT    % leave the clause
  2285.  
  2286. a_func0:    % executes arithmic function without arguments, pushing
  2287.         % its value on the stack
  2288. a_func1:    % unary function. Changes the top of the stack.
  2289. a_func2:    % binary function. Pops two values and pushes one.
  2290.  
  2291. Note that we do not call `ar_func0(*PC++, &ARGP)' as ARGP is a register
  2292. variable.  Also, for compilers that do register allocation it is unwise
  2293. to give the compiler a hint to put ARGP not into a register.
  2294. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2295.  
  2296.     VMI(A_ENTER, COUNT(a_enter), ("a_enter")) MARK(AENTER)
  2297.       { 
  2298. #ifdef DOUBLE_ALIGNMENT
  2299.     ARGP = (Word) (((unsigned long)ARGP + (DOUBLE_ALIGNMENT-1)) &
  2300.                ~(DOUBLE_ALIGNMENT-1));
  2301. #endif
  2302.         NEXT_INSTRUCTION;
  2303.       }
  2304.  
  2305.     VMI(A_INTEGER, COUNT(a_integer), ("a_integer %d\n", *PC)) MARK(AINT);
  2306.       {    Number n = (Number)ARGP;
  2307.  
  2308.     n->value.i = (long) *PC++;
  2309.     n->type    = V_INTEGER;
  2310.     ARGP       = (Word)(n+1);
  2311.     NEXT_INSTRUCTION;
  2312.       }
  2313.  
  2314.     VMI(A_DOUBLE, COUNT(a_double), ("a_double %d\n", *PC)) MARK(ADOUBLE);
  2315.       {    Number n = (Number)ARGP;
  2316.  
  2317.     n->value.w[0] = *PC++;
  2318.     n->value.w[1] = *PC++;
  2319.     n->type       = V_REAL;
  2320.     ARGP          = (Word)(n+1);
  2321.     NEXT_INSTRUCTION;
  2322.       }
  2323.  
  2324.     VMI(A_VAR, COUNT_N(a_var_n), ("a_var %d\n", *PC)) MARK(AVARN);
  2325.     { int offset = *PC++;
  2326.       term_t v;
  2327.       Number n;
  2328.  
  2329.     a_var_n:
  2330.       v = consTermRef(varFrameP(FR, offset));
  2331.       n = (Number)ARGP;
  2332.  
  2333.       if ( valueExpression(v, n) )
  2334.       { ARGP = (Word)(n+1);
  2335.     NEXT_INSTRUCTION;
  2336.       } else
  2337.       {
  2338. #if O_CATCHTHROW
  2339.     if ( exception_term )
  2340.       goto b_throw;
  2341. #endif
  2342.     BODY_FAILED;            /* check this */
  2343.       }
  2344.  
  2345.     VMI(A_VAR0, COUNT(a_var0), ("a_var0\n")) MARK(AVAR0);
  2346.       offset = ARGOFFSET / sizeof(word);
  2347.       goto a_var_n;
  2348.     VMI(A_VAR1, COUNT(a_var1), ("a_var1\n")) MARK(AVAR1);
  2349.       offset = ARGOFFSET / sizeof(word) + 1;
  2350.       goto a_var_n;
  2351.     VMI(A_VAR2, COUNT(a_var2), ("a_var2\n")) MARK(AVAR2);
  2352.       offset = ARGOFFSET / sizeof(word) + 2;
  2353.       goto a_var_n;
  2354.     }
  2355.  
  2356.     VMI(A_FUNC0, COUNT_N(a_func0), ("a_func0 %d\n", *PC)) MARK(A_FUNC0);
  2357.       {    Number n = (Number) ARGP;
  2358.     if ( !ar_func_n(*PC++, 0, &n) )
  2359.       BODY_FAILED;
  2360.     ARGP = (Word) n;
  2361.     NEXT_INSTRUCTION;
  2362.       }
  2363.  
  2364.     VMI(A_FUNC1, COUNT_N(a_func1), ("a_func1 %d\n", *PC)) MARK(A_FUNC1);
  2365.       {    Number n = (Number) ARGP;
  2366.     if ( !ar_func_n(*PC++, 1, &n) )
  2367.       BODY_FAILED;
  2368.     ARGP = (Word) n;
  2369.     NEXT_INSTRUCTION;
  2370.       }
  2371.  
  2372.     VMI(A_FUNC2, COUNT_N(a_func2), ("a_func2 %d\n", *PC)) MARK(A_FUNC2);
  2373.       {    Number n = (Number) ARGP;
  2374.     if ( !ar_func_n(*PC++, 2, &n) )
  2375.       BODY_FAILED;
  2376.     ARGP = (Word) n;
  2377.     NEXT_INSTRUCTION;
  2378.       }
  2379.  
  2380.     VMI(A_FUNC, COUNT_N(a_func), ("a_func %d %d\n",*PC,PC[1])) MARK(A_FUNC);
  2381.       {    Number n = (Number) ARGP;
  2382.     if ( !ar_func_n(*PC++, *PC++, &n) )
  2383.       BODY_FAILED;
  2384.     ARGP = (Word) n;
  2385.     NEXT_INSTRUCTION;
  2386.       }
  2387.  
  2388. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2389. Translation of the arithmic comparison predicates (<, >, =<,  >=,  =:=).
  2390. Both sides are pushed on the stack, so we just compare the two values on
  2391. the  top  of  this  stack  and  backtrack  if  they  do  not suffice the
  2392. condition.  Example translation: `a(Y) :- b(X), X > Y'
  2393.  
  2394.     ENTER
  2395.     B_FIRSTVAR 1    % Link X from B's frame to a new var in A's frame
  2396.     CALL 0        % call b/1
  2397.     A_VAR 1        % Push X
  2398.     A_VAR 0        % Push Y
  2399.     A_GT        % compare
  2400.     EXIT
  2401. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2402.  
  2403.     VMI(A_LT, COUNT(a_lt), ("a_lt\n")) MARK(A_LT);
  2404.       { Number n = (Number)ARGP;
  2405.     n -= 2;
  2406.     ARGP = (Word)n;
  2407.     if ( !ar_compare(n, n+1, LT) )
  2408.       BODY_FAILED;
  2409.     ARGP = argFrameP(lTop, 0);
  2410.     NEXT_INSTRUCTION;
  2411.       }
  2412.  
  2413.     VMI(A_LE, COUNT(a_le), ("a_le\n")) MARK(A_LE);
  2414.       { Number n = (Number)ARGP;
  2415.     n -= 2;
  2416.     ARGP = (Word)n;
  2417.     if ( !ar_compare(n, n+1, LE) )
  2418.       BODY_FAILED;
  2419.     ARGP = argFrameP(lTop, 0);
  2420.     NEXT_INSTRUCTION;
  2421.       }
  2422.  
  2423.     VMI(A_GT, COUNT(a_gt), ("a_gt\n")) MARK(A_GT);
  2424.       { Number n = (Number)ARGP;
  2425.     n -= 2;
  2426.     ARGP = (Word)n;
  2427.     if ( !ar_compare(n, n+1, GT) )
  2428.       BODY_FAILED;
  2429.     ARGP = argFrameP(lTop, 0);
  2430.     NEXT_INSTRUCTION;
  2431.       }
  2432.  
  2433.     VMI(A_GE, COUNT(a_ge), ("a_ge\n")) MARK(A_GE);
  2434.       { Number n = (Number)ARGP;
  2435.     n -= 2;
  2436.     ARGP = (Word)n;
  2437.     if ( !ar_compare(n, n+1, GE) )
  2438.       BODY_FAILED;
  2439.     ARGP = argFrameP(lTop, 0);
  2440.     NEXT_INSTRUCTION;
  2441.       }
  2442.  
  2443.     VMI(A_EQ, COUNT(a_eq), ("a_eq\n")) MARK(A_EQ);
  2444.       { Number n = (Number)ARGP;
  2445.     n -= 2;
  2446.     ARGP = (Word)n;
  2447.     if ( !ar_compare(n, n+1, EQ) )
  2448.       BODY_FAILED;
  2449.     ARGP = argFrameP(lTop, 0);
  2450.     NEXT_INSTRUCTION;
  2451.       }
  2452.  
  2453.     VMI(A_NE, COUNT(a_ne), ("a_ne\n")) MARK(A_NE);
  2454.       { Number n = (Number)ARGP;
  2455.     n -= 2;
  2456.     ARGP = (Word)n;
  2457.     if ( !ar_compare(n, n+1, NE) )
  2458.       BODY_FAILED;
  2459.     ARGP = argFrameP(lTop, 0);
  2460.     NEXT_INSTRUCTION;
  2461.       }
  2462.  
  2463. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2464. Translation of is/2.  The stack has two pushed values: the variable for
  2465. the result (a word) and the number holding the result.  For example:
  2466.  
  2467.      a(X) :- X is sin(3).
  2468.  
  2469.     I_ENTER
  2470.     B_VAR 0            push left argument of is/2
  2471.     A_INTEGER 3        push integer as number
  2472.     A_FUNC <sin>        run function on it
  2473.     A_IS            bind value
  2474.     I_EXIT
  2475. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2476.  
  2477.     VMI(A_IS, COUNT(a_is), ("a_is\n")) MARK(A_IS);
  2478.       { Number n = (Number)ARGP;
  2479.     Word k;
  2480.  
  2481.     n--;                /* pop the number */
  2482.     ARGP = argFrameP(lTop, 0);    /* 1-st argument */
  2483.     deRef2(ARGP, k);
  2484.     canoniseNumber(n);        /* whole real --> long */
  2485.  
  2486.     if ( isVar(*k) )
  2487.     { Mark(lTop->mark);
  2488.       TrailLG(k, lTop);
  2489.       if ( intNumber(n) )
  2490.       { if ( inTaggedNumRange(n->value.i) )
  2491.           *k = consInt(n->value.i);
  2492.         else
  2493.           *k = globalLong(n->value.i);
  2494.       } else
  2495.         *k = globalReal(n->value.f);
  2496.       NEXT_INSTRUCTION;
  2497.     } else
  2498.     { if ( isInteger(*k) && intNumber(n) && valInteger(*k) == n->value.i )
  2499.         NEXT_INSTRUCTION;
  2500.       if ( isReal(*k) && floatNumber(n) && valReal(*k) == n->value.f )
  2501.         NEXT_INSTRUCTION;
  2502.     }
  2503.  
  2504.     BODY_FAILED;
  2505.       }
  2506. #endif /* O_COMPILE_ARITH */
  2507.  
  2508. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2509. I_USERCALL0 is generated by the compiler if a variable is encountered as
  2510. a subclause. Note that the compount   statement  opened here is encloses
  2511. also I_APPLY and I_CALL. This allows us to use local register variables,
  2512. but still jump to the `normal_call' label to   do the common part of all
  2513. these three virtual machine instructions.
  2514.  
  2515. I_USERCALL0 has the task of  analysing  the   goal:  it  should fill the
  2516. ->procedure slot of the new frame and  save the current program counter.
  2517. It also is responsible of filling the   argument part of the environment
  2518. frame with the arguments of the term.
  2519.  
  2520. BUG: have to find out how to proceed in case of failure (I am afraid the
  2521. `goto frame_failed' is a bit dangerous here).
  2522. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2523. #if O_CATCHTHROW
  2524.     i_usercall0:            /* from B_THROW */
  2525. #endif
  2526.     VMI(I_USERCALL0, COUNT(i_usercall0), ("user_call0\n")) MARK(USRCL0);
  2527.       { word goal;
  2528.     int arity;
  2529.     Word args, a;
  2530.     int n;
  2531.     register LocalFrame next;
  2532.     Module module;
  2533.     functor_t functor;
  2534.     int callargs;
  2535.  
  2536.     next = lTop;
  2537.     a = argFrameP(next, 0);        /* get the (now) instantiated */
  2538.     deRef(a);            /* variable */
  2539.  
  2540.     module = NULL;
  2541.     if ((a = stripModule(a, &module)) == (Word) NULL)
  2542.       FRAME_FAILED;
  2543.  
  2544. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2545. Determine the functor definition associated with the goal as well as the
  2546. arity and a pointer to the argument vector of the goal.
  2547. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2548.  
  2549.     if ( isAtom(goal = *a) )
  2550.     { if ( *a == ATOM_cut )
  2551.         goto i_cut;
  2552.       functor = lookupFunctorDef(goal, 0);
  2553.       arity   = 0;
  2554.       args    = NULL;
  2555.     } else if ( isTerm(goal) )
  2556.     { args    = argTermP(goal, 0);
  2557.       functor = functorTerm(goal);
  2558.       arity   = arityFunctor(functor);
  2559.     } else
  2560.     { warning("call/1 or variable as subclause: Illegal goal");
  2561.       FRAME_FAILED;
  2562.     }
  2563.     goto i_usercall_common;
  2564.  
  2565.     VMI(I_USERCALLN, COUNT_N(i_usercalln), ("user_calln %d\n", *PC)) MARK(USRCLN);
  2566.         callargs = *PC++;
  2567.     next = lTop;
  2568.     a = argFrameP(next, 0);        /* get the (now) instantiated */
  2569.     deRef(a);            /* variable */
  2570.  
  2571.     module = NULL;
  2572.     if ((a = stripModule(a, &module)) == (Word) NULL)
  2573.       FRAME_FAILED;
  2574.     if ( isAtom(goal = *a) )
  2575.     { arity   = 0;
  2576.       functor = lookupFunctorDef(goal, callargs);
  2577.       args    = NULL;
  2578.     } else if ( isTerm(goal) )
  2579.     { FunctorDef fdef = valueFunctor(functorTerm(goal));
  2580.  
  2581.       arity   = fdef->arity;
  2582.       functor = lookupFunctorDef(fdef->name, arity + callargs);
  2583.       args    = argTermP(goal, 0);
  2584.     } else
  2585.     { warning("call/%d: Illegal goal", callargs+1);
  2586.       FRAME_FAILED;
  2587.     }
  2588.  
  2589.     if ( arity != 1 )
  2590.     { int i, shift = arity - 1;
  2591.  
  2592.       a = argFrameP(next, 1);    /* pointer to 1-st arg */
  2593.       
  2594.       if ( shift > 0 )
  2595.       { for(i=callargs-1; i>=0; i--)
  2596.         { if ( isRef(a[i]) )
  2597.           { Word a1 = unRef(a[i]);
  2598.         
  2599.         if ( a1 >= a && a1 < a+arity )
  2600.           a[i+shift] = makeRefLG(a1+shift);
  2601.         else
  2602.           a[i+shift] = a[i];
  2603.           } else
  2604.         a[i+shift] = a[i];
  2605.         }
  2606.       } else
  2607.       { for(i=0; i < callargs; i++)
  2608.         { if ( isRef(a[i]) )
  2609.           { Word a1 = unRef(a[i]);
  2610.         
  2611.         if ( a1 >= a && a1 < a+arity )
  2612.           a[i+shift] = makeRefLG(a1+shift);
  2613.         else
  2614.           a[i+shift] = a[i];
  2615.           } else
  2616.         a[i+shift] = a[i];
  2617.         }
  2618.       }
  2619.     }
  2620.  
  2621.     i_usercall_common:
  2622.     next->flags = FR->flags;
  2623.     if ( true(DEF, HIDE_CHILDS) )
  2624.       set(next, FR_NODEBUG);
  2625.  
  2626. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2627. Now scan the argument vector of the goal and fill the arguments  of  the
  2628. frame.
  2629. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2630.     if ( arity > 0 )
  2631.     { ARGP = argFrameP(next, 0);
  2632.  
  2633.       for(; arity-- > 0; ARGP++, args++)
  2634.       { Word a;
  2635.  
  2636.         deRef2(args, a);
  2637.         *ARGP = (isVar(*a) ? makeRefLG(a) : *a);
  2638.       }
  2639.     }
  2640.  
  2641. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2642. Find the associated procedure.  First look in the specified module.   If
  2643. the function is not there then look in the user module.  Finally specify
  2644. the context module environment for the goal. This is not necessary if it
  2645. will  be  specified  correctly  by  the goal started.  Otherwise tag the
  2646. frame and write  the  module  name  just  below  the  frame.   See  also
  2647. contextModule().
  2648. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2649.  
  2650.     DEF = resolveProcedure(functor, module)->definition;
  2651.  
  2652. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2653. Save the program counter (note  that   I_USERCALL0  has no argument) and
  2654. continue as with a normal call.
  2655. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2656.  
  2657.     next->context = module;
  2658.     goto normal_call;
  2659.     
  2660. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2661. Fast control functions. Should  set-up  normal   call  if  the  function
  2662. doesn't exist.
  2663. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2664.  
  2665.     VMI(I_FAIL, COUNT(i_fail), ("i_fail\n")) MARK(I_FAIL);
  2666. #ifdef O_DEBUGGER
  2667.       if ( debugstatus.debugging )
  2668.       { next = lTop;
  2669.     next->flags = FR->flags;
  2670.     if ( true(DEF, HIDE_CHILDS) ) /* parent has hide_childs */
  2671.       set(next, FR_NODEBUG);
  2672.     DEF = lookupProcedure(FUNCTOR_fail0, MODULE_system)->definition;
  2673.     next->context = FR->context;
  2674.  
  2675.     goto normal_call;
  2676.       }
  2677. #endif
  2678.       BODY_FAILED;
  2679.  
  2680.     VMI(I_TRUE, COUNT(i_true), ("i_true\n")) MARK(I_TRUE);
  2681. #ifdef O_DEBUGGER
  2682.       if ( debugstatus.debugging )
  2683.       { next = lTop;
  2684.     next->flags = FR->flags;
  2685.     if ( true(DEF, HIDE_CHILDS) ) /* parent has hide_childs */
  2686.       set(next, FR_NODEBUG);
  2687.     DEF = lookupProcedure(FUNCTOR_true0, MODULE_system)->definition;
  2688.     next->context = FR->context;
  2689.  
  2690.     goto normal_call;
  2691.       }
  2692. #endif
  2693.       NEXT_INSTRUCTION;
  2694.  
  2695. #if O_COMPILE_OR
  2696. #ifdef O_SOFTCUT
  2697. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2698. A *-> B ; C is translated to C_SOFIF <A> C_SOFTCUT <B> C_JMP end <C>.  See
  2699. pl-comp.c and C_SOFTCUT implementation for details.
  2700. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2701.     VMI(C_SOFTIF, COUNT_2N(c_softif), ("c_softif %d\n", *PC)) MARK(C_SOFTIF);
  2702.       { varFrame(FR, *PC++) = (word) lTop; /* see C_SOFTCUT */
  2703.  
  2704.     goto c_or;
  2705.       }
  2706.  
  2707. #endif
  2708. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2709. If-then-else is a contraction of C_MARK and C_OR.  This contraction  has
  2710. been  made  to help the decompiler distinguis between (a ; b) -> c and a
  2711. -> b ; c, which would otherwise only be  possible  to  distinguis  using
  2712. look-ahead.
  2713.  
  2714. The asm("nop") is a tricky. The problem   is that C_NOT and C_IFTHENELSE
  2715. are the same instructions. The one is generated on \+/1 and the other on
  2716. (Cond -> True ; False). Their different   virtual-machine  id is used by
  2717. the decompiler. Now, as the VMCODE_IS_ADDRESS   is  in effect, these two
  2718. instruction would become the same. The  asm("nop") ensures they have the
  2719. same *functionality*, but a *different* address.  If your machine does't
  2720. like nop, define the macro ASM_NOP in  your md-file to do something that
  2721. 1) has *no effect* and 2) is *not optimised* away by the compiler.
  2722. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2723.     VMI(C_NOT, {}, ("c_not %d\n", *PC))
  2724. #if VMCODE_IS_ADDRESS
  2725. #ifdef ASM_NOP
  2726.       ASM_NOP
  2727. #else
  2728.       asm("nop");
  2729. #endif
  2730. #endif
  2731.     VMI(C_IFTHENELSE, COUNT_2N(c_ifthenelse), ("c_ifthenelse %d\n", *PC))
  2732.       MARK(C_ITE);
  2733.       { varFrame(FR, *PC++) = (word) BFR; /* == C_MARK */
  2734.  
  2735.     /*FALL-THROUGH to C_OR*/
  2736.       }
  2737.  
  2738. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2739. C_OR introduces a backtrack point within the clause.   The  argument  is
  2740. how  many  entries  of  the  code  array  to skip should backtracking be
  2741. necessary.  It is implemented by calling a foreign  functions  predicate
  2742. with as argument the amount of bytes to skip.  The foreign function will
  2743. on  first  call  succeed,  leaving  a  backtrack  point.   It does so by
  2744. returning the amount to skip as backtracking  argument.   On  return  it
  2745. will increment PC in its frame with this amount (which will be popped on
  2746. its exit) and succeed deterministically.
  2747.  
  2748. Note that this one is enclosed in the compound statement of I_USERCALL0,
  2749. I_APPLY, I_CALL and I_DEPART to allow   sharing of the register variable
  2750. `next' with them and thus make the `goto common_call' valid.
  2751.  
  2752. NOTE: as of SWI-Prolog 2.0.2, the call  to $alt/1 is `inlined'.  We just
  2753. build the frame for $alt/1 and then   continue execution.  This is ok as
  2754. the first call of $alt/1 simply succeeds.
  2755. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2756.     VMI(C_OR, COUNT_N(c_or), ("c_or %d\n", *PC)) MARK(C_OR);
  2757.     c_or:
  2758.       { int skip = *PC++;
  2759.     Word a;
  2760.  
  2761.     *ARGP++ = consInt(skip);    /* push amount to skip (as B_CONST) */
  2762.     DEBUG(9, Sdprintf("$alt(%d)\n", skip));
  2763.     next = lTop;
  2764.     next->flags = FR->flags;
  2765.     next->predicate = PROCEDURE_alt1->definition;
  2766.     next->programPointer = PC;
  2767.     next->context = MODULE_system;
  2768.  
  2769. #if NO_INLINE_C_OR            /* old code.  keep for debugging */
  2770.         DEF  = next->predicate;
  2771.     goto normal_call;
  2772. #else
  2773.         requireStack(local, (int)argFrameP((LocalFrame)NULL, 1));
  2774.     next->backtrackFrame = BFR;
  2775.     next->parent = FR;
  2776.     incLevel(next);
  2777.     clear(next, FR_CUT|FR_SKIPPED);
  2778.     LD->statistics.inferences++;
  2779.     Mark(next->mark);
  2780.     a = argFrameP(next, 0);        /* see callForeign() */
  2781.     lTop = (LocalFrame)argFrameP(a, 1);
  2782.                     /* callForeign() here */
  2783.     next->clause = (ClauseRef) (ForeignRedoIntVal(skip)|FRG_REDO);
  2784.     SetBfr(next);
  2785.     ARGP = argFrameP(lTop, 0);
  2786.  
  2787.     NEXT_INSTRUCTION;
  2788. #endif /*NO_INLINE_C_OR*/
  2789.       }
  2790. #endif /* O_COMPILE_OR */
  2791.  
  2792. #ifdef O_INLINE_FOREIGNS
  2793. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2794. I_CALL_FV[012] Call a deterministics foreign procedures  with a 0, 1, or
  2795. 2 arguments that appear as variables in   the  clause. This covers true,
  2796. fail, var(X) and other type-checking  predicates,   =/2  in  a number of
  2797. cases (i.e. X = Y, not X = 5).
  2798.  
  2799. The VMI for these calls are ICALL_FVN, proc, var-index ...
  2800. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2801.     { int nvars;
  2802.       Procedure fproc;
  2803.       Word v;
  2804.  
  2805.       VMI(I_CALL_FV0, COUNT(i_call_fv0), ("i_call_fv0")) MARK(CFV0);
  2806.       { fproc = (Procedure) *PC++;
  2807.     nvars = 0;
  2808.  
  2809.     goto common_call_fv;
  2810.       }
  2811.  
  2812.       VMI(I_CALL_FV1, COUNT(i_call_fv1), ("i_call_fv1")) MARK(CFV1);
  2813.       { fproc = (Procedure) *PC++;
  2814.     nvars = 1;
  2815.     v = varFrameP(FR, *PC++);
  2816.     *ARGP++ = (isVar(*v) ? makeRefLG(v) : *v);
  2817.     goto common_call_fv;
  2818.       }
  2819.  
  2820.       VMI(I_CALL_FV2, COUNT(i_call_fv2), ("i_call_fv2")) MARK(CFV2);
  2821.       { fproc = (Procedure) *PC++;
  2822.     nvars = 2;
  2823.     v = varFrameP(FR, *PC++);
  2824.     *ARGP++ = (isVar(*v) ? makeRefLG(v) : *v);
  2825.     v = varFrameP(FR, *PC++);
  2826.     *ARGP++ = (isVar(*v) ? makeRefLG(v) : *v);
  2827.  
  2828.       common_call_fv:
  2829.     if ( signalled )
  2830.       PL_handle_signals();
  2831.  
  2832.     { Definition def = fproc->definition;
  2833.       Func f = def->definition.function;
  2834.       int rval;
  2835.  
  2836.       if ( !f )
  2837.       { def = trapUndefined(def);
  2838.         f = def->definition.function;
  2839.       }
  2840.  
  2841. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2842. If we are debugging, just build a normal  frame and do the normal thing,
  2843. so the inline call is expanded to a normal call and may be traced.
  2844. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2845.  
  2846.       if ( !f ||
  2847. #ifdef O_DEBUGGER
  2848.            debugstatus.debugging ||
  2849. #endif
  2850.            false(def, FOREIGN) )
  2851.       { next = lTop;
  2852.         next->flags = FR->flags;
  2853.         if ( true(DEF, HIDE_CHILDS) ) /* parent has hide_childs */
  2854.           set(next, FR_NODEBUG);
  2855.         DEF = def;
  2856.         next->context = FR->context;
  2857.  
  2858.         goto normal_call;
  2859.       } else
  2860.       { LocalFrame oldtop = lTop;
  2861.         term_t h0;
  2862.         fid_t fid;
  2863.     
  2864. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2865. We must create a frame and mark the  stacks for two reasons: undo if the
  2866. foreign call fails *AND*  make  sure   Trail()  functions  properly.  We
  2867. increase lTop too to prepare for asynchronous interrupts.
  2868. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2869.  
  2870.         LD->statistics.inferences++;
  2871.         next = lTop;
  2872.         h0 = argFrameP(next, 0) - (Word)lBase;
  2873.         lTop = (LocalFrame) argFrameP(next, nvars);
  2874.         if ( true(def, METAPRED) )
  2875.           next->context = FR->context;
  2876.         else
  2877.           next->context = def->module;
  2878.         next->predicate      = def;
  2879.         next->programPointer = PC;
  2880.         next->parent         = FR;
  2881.         next->flags         = FR->flags;
  2882.         incLevel(next);
  2883.         next->backtrackFrame = BFR;
  2884. #ifdef O_PROFILE
  2885.         if ( LD->statistics.profiling )
  2886.           def->profile_calls++;
  2887. #endif /* O_PROFILE */
  2888.         environment_frame = next;
  2889.         Mark(next->mark);
  2890.  
  2891.         exception_term = 0;
  2892.         SAVE_REGISTERS(qid);
  2893.         fid = PL_open_foreign_frame();
  2894.         switch(nvars)
  2895.         { case 0:
  2896.         rval = (*f)();
  2897.             break;
  2898.           case 1:
  2899.         rval = (*f)(h0);
  2900.             break;
  2901.           case 2:
  2902.           default:
  2903.         rval = (*f)(h0, h0+1);
  2904.             break;
  2905.         }
  2906.         PL_close_foreign_frame(fid);
  2907.         LOAD_REGISTERS(qid);
  2908.  
  2909.         ARGP -= nvars;
  2910.         environment_frame = FR;
  2911.         lTop = oldtop;
  2912.  
  2913.         if ( rval )
  2914.         { exception_term = 0;
  2915.           NEXT_INSTRUCTION;
  2916.         }
  2917.  
  2918.         if ( exception_term )
  2919.           goto b_throw;
  2920.  
  2921.         Undo(next->mark);
  2922.         LD->statistics.inferences++;    /* is a redo! */
  2923.         BODY_FAILED;
  2924.       }
  2925.     }
  2926.       }
  2927.     }
  2928. #endif /*O_INLINE_FOREIGNS*/
  2929.  
  2930. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2931. I_APPLY is the code generated by the Prolog goal $apply/2 (see reference
  2932. manual for the definition of apply/2).  We   expect  a term in the first
  2933. argument of the frame and a  list   in  the second, comtaining aditional
  2934. arguments. Most comments of I_USERCALL0 apply   to I_APPLY as well. Note
  2935. that the two arguments are copied in  local variables as they will later
  2936. be overwritten by the arguments for the actual call.
  2937. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2938.       VMI(I_APPLY, COUNT(i_apply), ("apply\n")) MARK(APPLY);
  2939.       { atom_t functor;
  2940.     word list;
  2941.     Module module = (Module) NULL;
  2942.     Word gp;
  2943.  
  2944.     next = lTop;
  2945.     next->flags = FR->flags;
  2946.     if ( true(DEF, HIDE_CHILDS) )
  2947.       set(next, FR_NODEBUG);
  2948.  
  2949.     ARGP = argFrameP(next, 0); deRef(ARGP); gp = ARGP;
  2950.     ARGP = argFrameP(next, 1); deRef(ARGP); list = *ARGP;
  2951. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2952. Obtain the functor of the actual goal from the first argument  and  copy
  2953. the arguments of this term in the frame.
  2954. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2955.     
  2956.     if ((gp = stripModule(gp, &module)) == (Word) NULL)
  2957.       FRAME_FAILED;
  2958.     next->context = module;
  2959.     goal = *gp;
  2960.  
  2961.     ARGP = argFrameP(next, 0);
  2962.  
  2963.     if (isAtom(goal) )
  2964.     { functor = goal;
  2965.       arity = 0;
  2966.     } else if ( isTerm(goal) )
  2967.     { Functor     f = valueTerm(goal);
  2968.       FunctorDef fd = valueFunctor(f->definition);
  2969.  
  2970.       functor = fd->name;
  2971.       arity   = fd->arity;
  2972.       args    = f->arguments;
  2973.       for(n=0; n<arity; n++, ARGP++, args++)
  2974.       { deRef2(args, a);
  2975.         *ARGP = (isVar(*a) ? makeRefLG(a) : *a);
  2976.       }
  2977.     } else
  2978.     { warning("apply/2: Illegal goal");
  2979.       FRAME_FAILED;
  2980.     }
  2981. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2982. Scan the list and add the elements to the argument vector of the frame.
  2983. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  2984.     while(!isNil(list) )
  2985.     { if (!isList(list) )
  2986.       { warning("apply/2: Illegal argument list");
  2987.         FRAME_FAILED;
  2988.       }
  2989.       args = argTermP(list, 0);
  2990.       deRef(args);
  2991.       *ARGP++ = (isVar(*args) ? makeRefLG(args) : *args);
  2992.       arity++;
  2993.       if (arity > MAXARITY)
  2994.       { warning("apply/2: arity too high");
  2995.         FRAME_FAILED;
  2996.       }
  2997.       args = argTermP(list, 1);
  2998.       deRef(args);
  2999.       list = *args;
  3000.     }
  3001. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  3002. Find the associated procedure (see I_CALL for module handling), save the
  3003. program pointer and jump to the common part.
  3004. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  3005.     { functor_t fdef;
  3006.  
  3007.       fdef = lookupFunctorDef(functor, arity);
  3008.       DEF = resolveProcedure(fdef, module)->definition;
  3009.       next->context = module;
  3010.     }
  3011.  
  3012.     goto normal_call;
  3013.       }
  3014. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  3015. I_CALL and I_DEPART form the normal code generated by the  compiler  for
  3016. calling  predicates.   The  arguments  are  already written in the frame
  3017. starting at `lTop'.  I_DEPART implies it is the last  subclause  of  the
  3018. clause.  This is be the entry point for tail recursion optimisation.
  3019.  
  3020. The task of I_CALL is to  save  necessary  information  in  the  current
  3021. frame,  fill  the next frame and initialise the machine registers.  Then
  3022. execution can continue at `next_instruction'
  3023. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  3024. #define TAILRECURSION 1
  3025.       VMI(I_DEPART, COUNT(i_depart), ("depart %d\n", *PC)) MARK(DEPART);
  3026. #if TAILRECURSION
  3027.     if ( true(FR, FR_CUT) && BFR <= FR
  3028. #if O_DEBUGGER
  3029.          && !debugstatus.debugging
  3030. #endif
  3031.        )
  3032.     { 
  3033. #if O_DEBUGGER
  3034.       if ( true(FR, FR_WATCHED) )
  3035.       { LocalFrame lSave = lTop;
  3036.         arity = ((Procedure) *PC)->definition->functor->arity;
  3037.  
  3038.         lTop = (LocalFrame)argFrameP(lTop, arity);
  3039.         frameFinished(FR);
  3040.         lTop = lSave;
  3041.       }
  3042. #endif
  3043.         leaveDefinition(DEF);
  3044.       if ( true(DEF, HIDE_CHILDS) )
  3045.         set(FR, FR_NODEBUG);
  3046.       
  3047.       FR->predicate = DEF = ((Procedure) *PC++)->definition;
  3048.       copyFrameArguments(lTop, FR, DEF->functor->arity);
  3049.  
  3050.       goto depart_continue;
  3051.     }
  3052. #endif /*TAILRECURSION*/
  3053.        /*FALLTHROUGH*/
  3054.       VMI(I_CALL,
  3055.       COUNT(i_call),
  3056.       ("call %s\n", procedureName((Procedure)*PC)))
  3057.       MARK(CALL);
  3058.         next = lTop;
  3059.         next->flags = FR->flags;
  3060.     if ( true(DEF, HIDE_CHILDS) )        /* parent has hide_childs */
  3061.       set(next, FR_NODEBUG);
  3062.     DEF = ((Procedure) *PC++)->definition;
  3063.     next->context = FR->context;
  3064.  
  3065. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  3066. This is the common part of the call variations.  By now the following is
  3067. true:
  3068.  
  3069.   - arguments, nodebug        filled
  3070.   - context            filled with context for
  3071.                 transparent predicate
  3072.   - DEF                filled
  3073. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  3074.  
  3075.       normal_call:
  3076.     requireStack(local, (int)argFrameP((LocalFrame)NULL, MAXARITY));
  3077.  
  3078. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  3079. Initialise those slots of the frame that are common to Prolog predicates
  3080. and foreign ones.  There might be some possibilities for optimisation by
  3081. delaying these initialisations till they are really  needed  or  because
  3082. the information they are calculated from is destroyed.  This probably is
  3083. not worthwile.
  3084.  
  3085. Note: we are working above `lTop' here!
  3086. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  3087.     next->backtrackFrame = BFR;
  3088.     next->parent         = FR;
  3089.     next->predicate         = DEF;        /* TBD */
  3090.     next->programPointer = PC;        /* save PC in child */
  3091.     environment_frame = FR = next;        /* open the frame */
  3092.  
  3093.       depart_continue:
  3094.  
  3095. #ifdef O_DEBUGLOCAL
  3096.       {    Word ap = argFrameP(FR, DEF->functor->arity);
  3097.     int n;
  3098.     
  3099.     for(n=50; --n; )
  3100.       *ap++ = (word)(((char*)ATOM_nil) + 1);
  3101.       }
  3102. #endif
  3103.  
  3104.     incLevel(FR);
  3105. #ifdef O_DEBUGGER
  3106.       retry_continue:
  3107. #endif
  3108.     clear(FR, FR_CUT|FR_SKIPPED|FR_WATCHED);
  3109.  
  3110.     LD->statistics.inferences++;
  3111.     Mark(FR->mark);
  3112.  
  3113.     if ( signalled )
  3114.       PL_handle_signals();
  3115.  
  3116. #if O_ASYNC_HOOK            /* Asynchronous hooks */
  3117.     { if ( async.hook &&
  3118.            !((++LD->statistics.inferences & async.mask)) )
  3119.         (*async.hook)();        /* check the hook */
  3120.     }
  3121. #endif
  3122.  
  3123. #ifdef O_PROFILE
  3124.     if (LD->statistics.profiling)
  3125.       DEF->profile_calls++;
  3126. #endif /* O_PROFILE */
  3127.  
  3128.  
  3129. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  3130. Undefined   predicate detection and   handling.  trapUndefined() takes
  3131. care of  linking from the  public  modules  or  calling  the exception
  3132. handler.
  3133.  
  3134. Note that DEF->definition is  a  union  of  the clause  or C-function.
  3135. Testing is suffices to find out that the predicate is defined.
  3136. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  3137.  
  3138.     if ( !DEF->definition.clauses && false(DEF, DYNAMIC) )    
  3139.     { lTop = (LocalFrame) argFrameP(FR, DEF->functor->arity);
  3140.  
  3141.       FR->predicate = DEF = trapUndefined(DEF);
  3142.  
  3143.       if ( !DEF->definition.clauses &&
  3144.            false(DEF, DYNAMIC) &&
  3145.            true(DEF->module, UNKNOWN) )
  3146.       { PL_error(NULL, 0, NULL, ERR_UNDEFINED_PROC, DEF);
  3147.         goto b_throw;
  3148.       }
  3149.     }
  3150.  
  3151.     if ( false(DEF, METAPRED) )
  3152.       FR->context = DEF->module;
  3153.     if ( false(DEF, SYSTEM) )
  3154.       clear(FR, FR_NODEBUG);
  3155.  
  3156. #if O_DYNAMIC_STACKS
  3157.     if ( gc_status.requested )
  3158.     { lTop = (LocalFrame) argFrameP(FR, DEF->functor->arity);
  3159.       garbageCollect(FR);
  3160.     }
  3161. #else /*O_DYNAMIC_STACKS*/
  3162. #if O_SHIFT_STACKS
  3163.       { int gshift = narrowStack(global);
  3164.     int lshift = narrowStack(local);
  3165.     int tshift = narrowStack(trail);
  3166.  
  3167.     if ( gshift || lshift || tshift )
  3168.     { lTop = (LocalFrame) argFrameP(FR, DEF->functor->arity);
  3169.  
  3170.       if ( gshift || tshift )
  3171.       { long gused = usedStack(global);
  3172.         long tused = usedStack(trail);
  3173.  
  3174.         garbageCollect(FR);
  3175.         DEBUG(1, Sdprintf("\tgshift = %d; tshift = %d", gshift, tshift));
  3176.         if ( gshift )
  3177.           gshift = ((2 * usedStack(global)) > gused);
  3178.         if ( tshift )
  3179.           tshift = ((2 * usedStack(trail)) > tused);
  3180.         DEBUG(1, Sdprintf(" --> gshift = %d; tshift = %d\n",
  3181.                 gshift, tshift));
  3182.       }
  3183.  
  3184.       if ( gshift || tshift || lshift )
  3185.       { SAVE_REGISTERS(qid);
  3186.         growStacks(FR, NULL, lshift, gshift, tshift);
  3187.         LOAD_REGISTERS(qid);
  3188.       }
  3189.     }
  3190.       }
  3191. #else /*O_SHIFT_STACKS*/
  3192.     if ( narrowStack(global) || narrowStack(trail) )
  3193.     { lTop = (LocalFrame) argFrameP(FR, DEF->functor->arity);
  3194.       garbageCollect(FR);
  3195.     }
  3196. #endif /*O_SHIFT_STACKS*/
  3197. #endif /*O_DYNAMIC_STACKS*/
  3198.  
  3199. #if O_DEBUGGER
  3200.     if ( debugstatus.debugging )
  3201.     { lTop = (LocalFrame) argFrameP(FR, DEF->functor->arity);
  3202.       CL = DEF->definition.clauses;
  3203.       switch(tracePort(FR, BFR, CALL_PORT, NULL))
  3204.       { case ACTION_FAIL:    goto frame_failed;
  3205.         case ACTION_IGNORE: goto exit_builtin;
  3206.         case ACTION_RETRY:  goto retry;
  3207.       }
  3208.     }
  3209. #endif /*O_DEBUGGER*/
  3210.  
  3211.     if ( true(DEF, FOREIGN) )
  3212.     { int rval;
  3213.  
  3214.       CL = (ClauseRef) FIRST_CALL;
  3215.     call_builtin:            /* foreign `redo' action */
  3216.       SAVE_REGISTERS(qid);
  3217.       rval = callForeign(DEF, FR);
  3218.       LOAD_REGISTERS(qid);
  3219.       if ( rval )
  3220.         goto exit_builtin;
  3221.  
  3222. #if O_CATCHTHROW
  3223.       if ( exception_term )
  3224.       { goto b_throw;
  3225.       }
  3226. #endif
  3227.  
  3228.       goto frame_failed;
  3229.     } 
  3230.  
  3231. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  3232. Call a normal Prolog predicate.  Just   load  the machine registers with
  3233. values found in the clause,  give  a   reference  to  the clause and set
  3234. `lTop' to point to the first location after the current frame.
  3235. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  3236.     ARGP = argFrameP(FR, 0);
  3237.     enterDefinition(DEF);
  3238.  
  3239. #ifdef O_LIMIT_DEPTH
  3240.       { unsigned long depth = levelFrame(FR);
  3241.  
  3242.     if ( depth > depth_reached )
  3243.       depth_reached = depth;
  3244.     if ( depth > depth_limit )
  3245.        FRAME_FAILED;
  3246.       }
  3247. #endif
  3248.     DEBUG(9, Sdprintf("Searching clause ... "));
  3249.  
  3250.     lTop = (LocalFrame) argFrameP(FR, DEF->functor->arity);
  3251.     if ( !(CL = firstClause(ARGP, DEF, &deterministic)) )
  3252.     { DEBUG(9, Sdprintf("No clause matching index.\n"));
  3253.       FRAME_FAILED;
  3254.     }
  3255.     DEBUG(9, Sdprintf("Clauses found.\n"));
  3256.  
  3257.     if ( deterministic )
  3258.       set(FR, FR_CUT);
  3259.  
  3260.     { Clause clause = CL->clause;
  3261.  
  3262.       PC = clause->codes;
  3263.       lTop = (LocalFrame)(ARGP + clause->variables);
  3264.     }
  3265.  
  3266.     SECURE(
  3267.     int argc; int n;
  3268.     argc = DEF->functor->arity;
  3269.     for(n=0; n<argc; n++)
  3270.       checkData(argFrameP(FR, n));
  3271.     );
  3272.  
  3273.     NEXT_INSTRUCTION;
  3274.       }
  3275.  
  3276. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  3277. Leave the clause:
  3278.  
  3279.   - update reference of current clause
  3280.     If there are no alternatives left and BFR  <=  frame  we  will
  3281.     never  return  at  this clause and can decrease the reference count.
  3282.     If BFR > frame the backtrack frame is a child of  this  frame, 
  3283.     so  this frame can become active again and we might need to continue
  3284.     this clause.
  3285.  
  3286.   - update BFR
  3287.     `BFR' will become the backtrack frame of other childs  of  the
  3288.     parent  frame  in which we are going to continue.  If this frame has
  3289.     alternatives and is newer than the old backFrame `BFR'  should
  3290.     become this frame.
  3291.  
  3292.     If there are no alternatives and  the  BFR  is  this  one  the
  3293.     BFR can become this frame's backtrackframe.
  3294.  
  3295.   - Update `lTop'.
  3296.     lTop can be set to this frame if there are no alternatives  in  this
  3297.     frame  and  BFR  is  older  than this frame (e.g. there are no
  3298.     frames with alternatives that are newer).
  3299.  
  3300.   - restore machine registers from parent frame
  3301. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  3302.       {                MARK(I_EXIT);
  3303.     exit_builtin:
  3304.         if ( FR->clause )
  3305.     { if ( FR > BFR )
  3306.         SetBfr(FR);
  3307.     } else
  3308.     { assert(BFR <= FR);
  3309.       if ( BFR == FR )
  3310.         SetBfr(FR->backtrackFrame);
  3311.       lTop = FR;
  3312.     }
  3313.     goto normal_exit;
  3314.  
  3315. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  3316. i_exitfact is generated to close a fact. The reason for not generating a
  3317. plain I_EXIT is first of all that the actual sequence should be I_ENTER,
  3318. I_EXIT,  and  just  optimising   to    I_EXIT   looses   the  unify-port
  3319. interception. Second, there should be some room for optimisation here.
  3320. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  3321.     VMI(I_EXITFACT, COUNT(i_exitfact), ("exitfact ")) MARK(EXITFACT);
  3322. #if O_DEBUGGER
  3323.     if ( debugstatus.debugging )
  3324.     { switch(tracePort(FR, BFR, UNIFY_PORT, PC))
  3325.       { case ACTION_RETRY:
  3326.           goto retry;
  3327.       }
  3328.     }
  3329. #endif /*O_DEBUGGER*/
  3330.     /*FALLTHROUGH*/
  3331.  
  3332.     VMI(I_EXIT, COUNT(i_exit), ("exit ")) MARK(EXIT);
  3333.     if ( false(FR, FR_CUT) )
  3334.     { if ( FR > BFR )            /* alternatives */
  3335.         SetBfr(FR);
  3336.     } else
  3337.     { if ( BFR <= FR )            /* deterministic */
  3338.       { if ( BFR == FR )
  3339.           SetBfr(FR->backtrackFrame);
  3340.         leaveDefinition(DEF);
  3341.         lTop = FR;
  3342.       }
  3343.     }
  3344.  
  3345. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  3346. First, call the tracer. Basically,  the   current  frame is garbage, but
  3347. given that the tracer might need to print the variables, we have to be a
  3348. bit more careful.
  3349. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  3350.     normal_exit:
  3351. #if O_DEBUGGER
  3352.     if ( debugstatus.debugging )
  3353.         { LocalFrame mintop;
  3354.       int action;
  3355.  
  3356.       LocalFrame lSave = lTop;
  3357.       environment_frame = FR;
  3358.  
  3359.       if ( false(DEF, FOREIGN) && CL )
  3360.         mintop = (LocalFrame) argFrameP(FR, CL->clause->variables);
  3361.       else
  3362.         mintop = (LocalFrame) argFrameP(FR, DEF->functor->arity);
  3363.  
  3364.       if ( lTop < mintop )
  3365.         lTop = mintop;
  3366.  
  3367.       action = tracePort(FR, BFR, EXIT_PORT, PC);
  3368.       lTop = lSave;
  3369.       switch( action )
  3370.       { case ACTION_RETRY:    goto retry;
  3371.         case ACTION_FAIL:    set(FR, FR_CUT);
  3372.                 FRAME_FAILED;
  3373.       }
  3374.     }
  3375. #endif /*O_DEBUGGER*/
  3376.  
  3377.     if ( !FR->parent )        /* query exit */
  3378.     { QF = QueryFromQid(qid);    /* may be shifted: recompute */
  3379.       QF->solutions++;
  3380.       QF->bfr = BFR;
  3381.  
  3382.       assert(FR == &QF->frame);
  3383.  
  3384.       if ( !BFR )            /* No alternatives */
  3385.       { LocalFrame fr, fr2;
  3386.  
  3387.         set(QF, PL_Q_DETERMINISTIC);
  3388.         set(FR, FR_CUT);        /* execute I_CUT */
  3389.         for(fr = BFR; fr > FR; fr = fr->backtrackFrame)
  3390.         { for(fr2 = fr; fr2->clause && fr2 > FR; fr2 = fr2->parent)
  3391.           { DEBUG(3, Sdprintf("discard %d\n", (Word)fr2 - (Word)lBase) );
  3392.         leaveFrame(fr2);
  3393.         fr2->clause = NULL;
  3394.           }
  3395.         }
  3396.  
  3397. #if O_DEBUGGER
  3398.         if ( true(FR, FR_WATCHED) )
  3399.           frameFinished(FR);
  3400. #endif
  3401.       }
  3402.  
  3403.       succeed;
  3404.     }
  3405.  
  3406.       {
  3407. #if O_DEBUGGER
  3408.     LocalFrame leave;
  3409.  
  3410.     leave = (true(FR, FR_WATCHED) && FR == lTop) ? FR : NULL;
  3411. #endif
  3412.  
  3413.     PC = FR->programPointer;
  3414.     environment_frame = FR = FR->parent;
  3415.     DEF = FR->predicate;
  3416.     ARGP = argFrameP(lTop, 0);
  3417.  
  3418. #if O_DEBUGGER
  3419.     if ( leave )
  3420.       frameFinished(leave);
  3421. #endif
  3422.       }
  3423.     NEXT_INSTRUCTION;
  3424.       }      
  3425.   }
  3426.  
  3427. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  3428.             TRACER RETRY ACTION
  3429.  
  3430. By default, retries the  current  frame.  If   another  frame  is  to be
  3431. retried, place the frame-reference, which  should   be  a  parent of the
  3432. current frame, in debugstatus.retryFrame and jump to this label. This is
  3433. implemented by returning retry(Frame) of the prolog_trace_interception/3
  3434. hook.
  3435.  
  3436. First, the system will leave any parent  frames. Next, it will undo back
  3437. to the call-port and finally, restart the clause.
  3438. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  3439.  
  3440. #if O_DEBUGGER
  3441. retry:                    MARK(RETRY);
  3442. { LocalFrame rframe = debugstatus.retryFrame;
  3443.   LocalFrame fr;
  3444.  
  3445.   if ( !rframe )
  3446.     rframe = FR;
  3447.   debugstatus.retryFrame = NULL;
  3448.  
  3449.   if ( rframe->mark.globaltop == INVALID_GLOBALTOP )
  3450.   { Sdprintf("[Undo mark lost by garbage collection]\n");
  3451.     rframe = FR;
  3452.     assert(rframe->mark.globaltop != INVALID_GLOBALTOP);
  3453.   }
  3454.  
  3455.   Sdprintf("[Retrying frame %d running %s]\n",
  3456.        (Word)rframe - (Word)lBase,
  3457.        predicateName(rframe->predicate));
  3458.  
  3459.   for(fr = BFR; fr > rframe; fr = fr->backtrackFrame)
  3460.   { LocalFrame fr2;
  3461.  
  3462.     for(fr2 = fr; fr2->clause && fr2 > rframe; fr2 = fr2->parent)
  3463.     { DEBUG(3, Sdprintf("discard %d\n", (Word)fr2 - (Word)lBase) );
  3464.       leaveFrame(fr2);
  3465.       fr2->clause = NULL;
  3466.     }
  3467.   }
  3468.  
  3469.   environment_frame = FR = rframe;
  3470.   DEF = FR->predicate;
  3471.   Undo(FR->mark);
  3472.   SetBfr(FR);
  3473.   clear(FR, FR_CUT);
  3474.   lTop = (LocalFrame) argFrameP(FR, DEF->functor->arity);
  3475.  
  3476.   goto retry_continue;
  3477. }
  3478. #endif /*O_DEBUGGER*/
  3479.  
  3480. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  3481. The rest of this giant procedure handles backtracking.  There are  three
  3482. different ways we can get here:
  3483.  
  3484.   - Head unification code failed            (clause_failed)
  3485.     In this case we should continue with the next clause of the  current
  3486.     procedure  and  if we are out of clauses continue with the backtrack
  3487.     frame of this frame.
  3488.  
  3489.   - A foreign goal failed                (frame_failed)
  3490.     In this case we can continue at the backtrack frame of  the  current
  3491.     frame.
  3492.  
  3493.   - Body instruction failed                (body_failed)
  3494.     This can only occur since arithmetic is compiled.   Future  versions
  3495.     might incorporate more WAM instructions that can fail.  In this case
  3496.     we should continue with frame BFR.
  3497.  
  3498. In  all  cases,  once  the  right  frame  to  continue  is  found   data
  3499. backtracking  can be invoked, the registers can be reloaded and the main
  3500. loop resumed.
  3501.  
  3502. The argument stack is set back to its base as we cannot  be  sure  about
  3503. it's current value.
  3504.  
  3505. The `shallow_backtrack' entry is used from `deep_backtrack'  to  do  the
  3506. common part.
  3507. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  3508.  
  3509. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  3510. A WAM instruction in the body wants to start backtracking.  If backtrack
  3511. frames have been created  after  this  frame  we  want  to  resume  that
  3512. backtrack frame.  In this case the current clause remains active.  If no
  3513. such frames are created the current clause fails.
  3514. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  3515.  
  3516. body_failed:                MARK(BKTRK);
  3517.   DEBUG(9, Sdprintf("body_failed\n"));
  3518.   if ( BFR > FR )
  3519.   { environment_frame = FR = BFR;
  3520.     goto resume_from_body;
  3521.   }
  3522.  
  3523. clause_failed:
  3524.   CL = CL->next;
  3525.   if ( !CL || true(FR, FR_CUT) )
  3526.     goto frame_failed;
  3527.  
  3528. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  3529. Resume frame FR.  CL points  to  the  next  (candidate)  clause.   First
  3530. indexing  is  activated  to find the next real candidate.  If this fails
  3531. the entire frame has failed, so we can continue at `frame_failed'.
  3532. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  3533.  
  3534. resume_frame:
  3535.   ARGP = argFrameP(FR, 0);
  3536.   Undo(FR->mark);            /* backtrack before clause indexing */
  3537.  
  3538.   if ( !(CL = findClause(CL, ARGP, DEF, &deterministic)) )
  3539.     goto frame_failed;
  3540.  
  3541.   if ( deterministic )
  3542.     set(FR, FR_CUT);
  3543.  
  3544.   SetBfr(FR->backtrackFrame);
  3545.   aTop = aFloor;            /* reset to start, for interrupts */
  3546.  
  3547.   { Clause clause = CL->clause;
  3548.  
  3549.     PC = clause->codes;
  3550.     lTop = (LocalFrame) argFrameP(FR, clause->variables);
  3551.   }
  3552.  
  3553.   NEXT_INSTRUCTION;
  3554.  
  3555. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  3556. Deep backtracking part of the system.  This code handles the failure  of
  3557. the goal associated with `frame'.  This would have been simple if we had
  3558. not  to  update  the clause references.  The main control loop will walk
  3559. along the backtrack frame links until either it reaches the top goal  or
  3560. finds a frame that really has a backtrack point left (the sole fact that
  3561. a  frame  is backtrackframe does not guaranty it still has alternatives:
  3562. the alternative clause might be retracted).
  3563. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  3564.  
  3565. frame_failed:                MARK(FAIL);
  3566.  
  3567.   for(;;)
  3568.   { DEF = FR->predicate;
  3569.  
  3570. #ifdef O_PROFILE
  3571.     if (LD->statistics.profiling)
  3572.       DEF->profile_fails++;
  3573. #endif
  3574.  
  3575. #if O_DEBUGGER
  3576.     if ( debugstatus.debugging )
  3577.     { switch( tracePort(FR, FR->backtrackFrame, FAIL_PORT, PC) )
  3578.       { case ACTION_RETRY:    goto retry;
  3579.     case ACTION_IGNORE:    Putf("ignore not (yet) implemented here\n");
  3580.       }
  3581.     }
  3582. #endif /*O_DEBUGGER*/
  3583.  
  3584. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  3585. Update references due to failure of this frame.  The references of  this
  3586. frame's  clause are already updated.  All frames that can be reached via
  3587. the parent links and are  created  after  the  backtrack  frame  can  be
  3588. visited for dereferencing.
  3589. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  3590.  
  3591.     if ( false(DEF, FOREIGN) )
  3592.       leaveDefinition(DEF);
  3593. #if O_DEBUGGER
  3594.     if ( true(FR, FR_WATCHED) )
  3595.       frameFinished(FR);
  3596. #endif
  3597.  
  3598.     if ( !FR->backtrackFrame )            /* top goal failed */
  3599.     { register LocalFrame fr = FR->parent;
  3600.  
  3601.       for(; fr; fr = fr->parent)
  3602.         leaveFrame(fr);
  3603.  
  3604.       QF = QueryFromQid(qid);
  3605.       set(QF, PL_Q_DETERMINISTIC);
  3606.  
  3607.       fail;
  3608.     }
  3609.  
  3610.     { register LocalFrame fr = FR->parent;
  3611.  
  3612.       environment_frame = FR = FR->backtrackFrame;
  3613.  
  3614.       for( ; fr > FR; fr = fr->parent )
  3615.         leaveFrame(fr);
  3616.     }
  3617.  
  3618. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  3619. References except for this frame are OK again.  First fix the references
  3620. for this frame if it is a Prolog frame.  This  cannot  be  in  the  loop
  3621. above as we need to put CL on the next clause.  Dereferencing the clause
  3622. might free it!
  3623. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  3624. resume_from_body:
  3625.  
  3626.     DEF = FR->predicate;
  3627.     if ( true(FR, FR_CUT) )
  3628.       continue;
  3629.     if ( false(DEF, FOREIGN) && !(CL = CL->next) )
  3630.       continue;
  3631.  
  3632. #if O_DEBUGGER
  3633.     if ( debugstatus.debugging )
  3634.     { Undo(FR->mark);            /* data backtracking to get nice */
  3635.                     /* tracer output */
  3636.  
  3637.       switch( tracePort(FR, BFR, REDO_PORT, NULL) )
  3638.       { case ACTION_FAIL:    continue;
  3639.     case ACTION_IGNORE:    CL = NULL;
  3640.                 goto exit_builtin;
  3641.     case ACTION_RETRY:    goto retry;
  3642.       }
  3643.     }
  3644. #endif /*O_DEBUGGER*/
  3645.     
  3646.     LD->statistics.inferences++;
  3647. #ifdef O_PROFILE
  3648.     if ( LD->statistics.profiling )
  3649.     { DEF->profile_fails++;        /* fake a failure! */
  3650.       DEF->profile_redos++;
  3651.     }
  3652. #endif /* O_PROFILE */
  3653.  
  3654. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  3655. Finaly restart.  If it is a Prolog frame this is the same as  restarting
  3656. as  resuming  a  frame after unification of the head failed.  If it is a
  3657. foreign frame we have to set BFR and do data backtracking.
  3658. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  3659.  
  3660.     if ( signalled )
  3661.       PL_handle_signals();
  3662.  
  3663.     if ( false(DEF, FOREIGN) )
  3664.       goto resume_frame;
  3665.  
  3666.     SetBfr(FR->backtrackFrame);
  3667.     Undo(FR->mark);
  3668.  
  3669.     goto call_builtin;
  3670.   }
  3671. } /* end of interpret() */
  3672.  
  3673.  
  3674. #if O_COMPILE_OR
  3675. word
  3676. pl_alt(term_t skip, word h)
  3677. { switch( ForeignControl(h) )
  3678.   { case FRG_FIRST_CALL:
  3679.     { int i;
  3680.  
  3681.       PL_get_integer(skip, &i);
  3682.       ForeignRedoInt(i);
  3683.     }
  3684.     case FRG_REDO:
  3685.     { int skip = ForeignContextInt(h);
  3686.       DEBUG(9, Sdprintf("$alt/1: skipping %ld codes\n", ForeignContextInt(h)));
  3687.       environment_frame->programPointer += skip;
  3688.       succeed;
  3689.     }
  3690.     case FRG_CUTTED:
  3691.     default:
  3692.       succeed;
  3693.   }
  3694. }
  3695. #endif /* O_COMPILE_OR */
  3696.